循环循环以搜索多个条件的匹配项

Question

我有两本工作簿和三张工作表。为简单起见，称它们为wb1Sheet1、wb1Sheet2 和wb2Sheet1。我的代码是：

1. 在 wb1Sheet2 的列中查找任何（非零）值以用作条件 (Crit)。
2. 对于每个条件，它都会搜索wb1Sheet1 的特定列。
3. 匹配的行被复制到另一个工作簿：wb2Sheet1。

当我为一个定义的标准编写此代码时，它工作正常。 但是，当我尝试将其修改为循环中的循环（将每个标准与每一行进行比较）时，它不起作用。

Dim wb1 As Workbook                     
Dim wb2 As Workbook                     
Dim src As Worksheet                    
Dim Dst As Worksheet                    
Dim src2 As Worksheet
Dim Crit As Range


Set wb1 = ActiveWorkbook                '
Set wb2 = Workbooks.Open(Filename:="C:\Test.xlsx")            
Set src = wb1.Sheets("wb1Sheet1")    
Set Dst = wb2.Sheets("wb2Sheet1")          
Set src2 = wb1.Sheets("wb1Sheet2")

Dim LastRow As Long, r As Range
Dim CopyRange As Range

LastRow = src.Cells(Cells.Rows.Count, "P").End(xlUp).Row
For Each Crit In src2.Range("G10:G")
    For Each r In src.Range("P2:P" & LastRow)
        If r.Value = Crit Then                               
            If CopyRange Is Nothing Then
                    Set CopyRange = r.EntireRow
            Else
                    Set CopyRange = Union(CopyRange, r.EntireRow)
            End If
        End If
    Next Crit
Next r
If Not CopyRange Is Nothing Then
CopyRange.Copy Dst.Range("A1")
End If
End Sub

Answer 1

我已更正代码并添加了忽略空单元格作为标准的功能。现在它工作正常。谢谢你的建议。不幸的是，为了限制循环，我必须使用一个常量，因为当我按照 BruceWayne 所说的那样编辑 LastRow 时，它会给出错误“应用程序定义或对象定义错误”

Sub Copy_Data_by_Criteria()

Dim wb1 As Workbook                     
Dim wb2 As Workbook                     
Dim src As Worksheet                    
Dim Dst As Worksheet                    
Dim src2 As Worksheet

Set wb1 = ActiveWorkbook                
Set wb2 = Workbooks.Open(Filename:="C:\Test.xlsx")            
Set src = wb1.Sheets("Sheet1")    
Set Dst = wb2.Sheets("Sheet1")          
Set src2 = wb1.Sheets("Base 1")

Dim LastRow As Long
Dim r As Range
Dim CopyRange As Range
Dim Crit As Range

' LastRow = src.Cells(src.Cells.Rows.Count, "P").End(x1Up).Row    

For Each Crit In src2.Range("G10:G" & 30)
    If Crit <> "" Then
        For Each r In src.Range("P6:P" & 100)
            If r.Value = Crit Then                                  
                If CopyRange Is Nothing Then
                        Set CopyRange = r.EntireRow
                Else
                        Set CopyRange = Union(CopyRange, r.EntireRow)
                End If
            End If
        Next r
    End If
Next Crit
If Not CopyRange Is Nothing Then
CopyRange.Copy Dst.Range("A1")
End If
End Sub