如果 50 个不同的变量满足 3 个条件，则复制 Excel 行

Question

我正在尝试编写一个宏，如果满足 3 个条件，它将复制行。如：

如果“A”=B，“D”=E，“F”=G 然后将行复制到工作表 2 上的下一个可用行

如果“A”=C，“D”=F，“F”=H 然后将行复制到工作表 2 上的下一个可用行

我需要重复上述步骤最多 50 次。列不会改变

这是我目前所拥有的：

`Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 4
LSearchRow = 4

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

    'If value in column E = "Mail Box", copy entire row to Sheet2
    'If value in column D = "0", copy entire row to Sheet2
    'If value in column A = "5", copy entire row to Sheet2
    'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then
    If Range("F" & CStr(LSearchRow)).Value = "Mail Box" And _
        Range("E" & CStr(LSearchRow)).Value = "0" And _
        Range("A" & CStr(LSearchRow)).Value = "5" Then

 'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

        'Select row in Sheet1 to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet2 in next row
        Sheets("Sheet2").Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1

        'Go back to Sheet1 to continue searching
        Sheets("Sheet1").Select

        End If

    LSearchRow = LSearchRow + 1

    Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

'MsgBox "All matching data has been copied."

'Exit Sub


        'Search 2

         'Start search in row 4
LSearchRow = 4

'Start copying data to row 3 in Sheet2 (row counter variable)
LCopyToRow = 3

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

    'If value in column E = "Mail Box", copy entire row to Sheet2
    'If value in column D = "1", copy entire row to Sheet2
    'If value in column A = "5", copy entire row to Sheet2
    'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then
    If Range("F" & CStr(LSearchRow)).Value = "Mail Box" And _
        Range("E" & CStr(LSearchRow)).Value = "1" And _
        Range("A" & CStr(LSearchRow)).Value = "5" Then

 'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

        'Select row in Sheet1 to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet2 in next row
        Sheets("Sheet2").Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1

        'Go back to Sheet1 to continue searching
        Sheets("Sheet1").Select

    End If

    LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

 Err_Execute:
MsgBox "An error occurred."

End Sub

Answer 1

我认为可能有更好的方法来完成您想要实现的目标，但也许这会对您有所帮助...

Sub Tester()
    SearchForString "5", "0", "Mail Box"
    SearchForString "5", "1", "Mail Box"
End Sub

Sub SearchForString(ColA, ColE, ColF)

Dim LSearchRow As Long
Dim shtSearch As Worksheet
Dim shtCopyTo As Worksheet
Dim rw As Range

    LSearchRow = 4 'Start search in row 4

    Set shtSearch = Sheets("Sheet1")
    Set shtCopyTo = Sheets("Sheet2")

    Do While Len(shtSearch.Cells(LSearchRow, 1).Value) > 0

        Set rw = shtSearch.Rows(LSearchRow)

        If rw.Cells(6).Value = ColF And rw.Cells(5).Value = ColE And _
                                        rw.Cells(1).Value = ColA Then

            rw.Copy shtCopyTo.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            Exit Do '? you say there's only one result to find
        End If
        LSearchRow = LSearchRow + 1
    Loop
End Sub