如果滿足3個條件的50個不同變量，複製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

我覺得可能有一個更好的方式做你想要什麼acheive，但也許這將幫助您延續.. 。

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