Hello begoodbetter,
Here is the updated version of your macro. Try it and let me know if anything needs to be changed.
Sub Copydatatosheet2()
'Copy cells of cols A to M from rows containing "SYMBOL AND EQ" in
'col D of the active worksheet (source sheet) to cols
'A to M of Sheet2 (destination sheet)
Dim DestSheet As Worksheet
Dim sData() As Variant
Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1
ReDim sData(1 To 11) 'Number of columns to be copied
Set DestSheet = Worksheets("Sheet2")
For sRow = 1 To Range("A65536").End(xlUp).Row
Select Case Cells(sRow, "B")
Case Is = "SERIES", "EQ"
Select Case Cells(sRow, "A")
Case Is = "Symbol", "ACC", "AMBUJACEM", "AXISBANK", "BAJAJ-AUTO", _
"BHARTIARTL", "BHEL", "BPCL"
sData(1) = Cells(sRow, "A")
sData(2) = Cells(sRow, "B")
sData(3) = Cells(sRow, "K")
sData(4) = Cells(sRow, "H")
sData(5) = Cells(sRow, "C")
sData(6) = Cells(sRow, "D")
sData(7) = Cells(sRow, "E")
sData(8) = Cells(sRow, "G")
sData(9) = Cells(sRow, "F")
sData(10) = Cells(sRow, "I")
sData(11) = Cells(sRow, "J")
sCount = sCount + 1
dRow = dRow + 1
DestSheet.Cells(dRow, "A").Resize(1, UBound(sData)).Value = sData
End Select
End Select
Next sRow
MsgBox sCount & " Significant rows copied", vbInformation, "Transfer Done"
End Sub
Bookmarks