hi leveleyed Try this macro out
Sub Test()
Dim Cell As Range, x As Integer, LastRow As Long
Application.ScreenUpdating = False
For x = 2 To Worksheets.Count
Sheets(x).Range("A11").Value = "VUSAL"
For Each Cell In Sheets(1).Range("A3:A42")
' Find Last Row num for each sheet
With Sheets(x).Range("A:A")
LastRow = .Cells(.Count, 1).End(xlUp).Row + 1
End With
If Cell.Value = Sheets(x).Name Then
Cell.Offset(0, 1).Resize(, 16).Copy
Sheets(x).Range("A" & LastRow).PasteSpecial (xlPasteValues)
Cell.Offset(0, 17).Copy
Sheets(x).Range("A" & LastRow).Offset(0, 24).PasteSpecial (xlPasteValues)
End If
Next Cell
Sheets(x).Range("A11").ClearContents
Next x
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Bookmarks