Question

我有两本工作簿和三张。为简单起见，请致电wb1Sheet1，wb1Sheet2和wb2Sheet1。我的代码是：

在wb1Sheet2列中查找任何（非零）值以用作条件（Crit）。
对于每个条件，它会搜索wb1Sheet1。
匹配的行将复制到另一个工作簿：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

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

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

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

1 个答案: