如果 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