如果单元格包含特定文本，则复制整行

Question

I'm trying to create a macro that does this: Check the values from a small list (I've used an array) Go in a worksheet and for every row that contains one of the values of the array copy the entire row in another worksheet. I've mixed other macros to create one but I got one problem, the macro check the value on the array and copies all the rows in my worksheet but every time it doesn't copy the first row found: ex, if row that contain "abl" are: 100,200 and 300, the macro just copy 200 and 300 ignoring 100. This is my macro

Sub Test_339_1()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Dim nam(1 To 7) As String, cel As Range, rng As Range
        i = 1
        Set rng = Worksheets("Ctr 339").Range("V4:V10")
        For Each cel In rng
            nam(i) = cel.Value
            i = i + 1
        Next cel
        For i = 1 To 7
            For Each cell In Sheets("FB03").Range("E:E")
                If cell.Value = nam(i) Then
                    matchRow = cell.Row
                    Rows(matchRow & ":" & matchRow).Copy
                    Sheets("Test_macro").Select
                    ActiveSheet.Rows(matchRow).Select
                    ActiveSheet.Paste
                    Sheets("FB03").Select
                End If
            Next
            Sheets("Test_macro").Select
        Next i
        Sheets("Test_macro").Select
        On Error Resume Next
        Range("A1:A50000").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Answer 1

Try this refactored code:

Sub Test_339_1()
Dim nam(1 To 7) As String, cel As Range, lastrow As Long
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    nam = Worksheets("Ctr 339").Range("V4:V10").Value
    lastrow = Sheets("FB03").Cells(Sheets("FB03").Rows.Count, "E").End(xlUp).Row
    For Each cell In Sheets("FB03").Range("E1:E" & lastrow)
        For i = 1 To 7
            If cell.Value = nam(i) Then
                matchRow = cell.Row
                Sheets("FB03").Rows(matchRow).Copy Sheets("Test_macro").Rows(Sheets("Test_macro").Cells(Sheets("Test_macro").Rows.Count, "E").End(xlUp).Row + 1)
                Exit For
            End If
        Next i
    Next cell
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With
End Sub

It should be quicker, It will not loop over 7 million times.

Answer 2

AutoFilter() should speed things up quite a bit:

Option Explicit

Sub Test_339_1()
    Dim nam As Variant

    nam = Application.Transpose(Worksheets("Ctr 339").Range("V4:V10").Value)
    With Sheets("FB03")
        With .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
            .AutoFilter Field:=1, Criteria1:=nam, Operator:=xlFilterValues '<--| filter referenced range on its 3rd column (i.e. "State") with 1
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filterd cells other than header
                With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
                    .EntireRow.Copy Sheets("Test_macro").Cells(.Cells(1, 1).Row,1)
                End With
            End If
        End With
        .AutoFilterMode = False
    End With
End Sub

you only need row 1 to be a header one, ie actual data to be filtered begin from row 2 downwards

also this pastes values in target sheet from cell A1 downwards without blank rows. Should original row sequence be respected, it can be done