循环search多个条件的匹配

我有两本练习册和三张床单。 为了简单起见，将它们wb1Sheet1 ， wb1Sheet2和wb2Sheet1 。 我的代码是：

1. 在wb1Sheet2的列中wb1Sheet2任何（非零）值用作条件（Crit）。
2. 对于每个标准，它将searchwb1Sheet1的特定列。
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

我已经更正了代码并添加了忽略空单元格作为标准的function。 现在它工作正常。 谢谢你的build议。 不幸的是，为了限制循环，我必须使用一个常量，因为当我像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