跨工作簿数据匹配提取

sj15627581616

Sub lxlpp()
    Application.ScreenUpdating = False
    Range("b:iv").Clear
    r = Sheets(2).Cells(Rows.Count, 1).End(3).Row
    arr = Sheets(2).[a1].Resize(r)
    brr = Sheets(1).UsedRange
    r = 0
    For j = 1 To UBound(brr, 2)
        For i = 1 To UBound(arr)
            If arr(i, 1) <> brr(i, j) Then
                GoTo l1
            End If
        Next i
        r = r + 1
        For i = 1 To UBound(brr)
            brr(i, r) = brr(i, j)
        Next i
l1:
    Next j
    If r > 0 Then
        Sheets(2).[b1].Resize(UBound(brr), r) = brr
    End If
    Application.ScreenUpdating = True
End Sub


这是单个工作簿列向列匹配的代码，我想修改成跨工作簿匹配，麻烦老师帮忙修改

凌空一羽

Sub lxlpp()
    Application.ScreenUpdating = False
    With Workbooks.Open(ThisWorkbook.Path & "\匹配数据存放.xls")
        brr = Sheets(1).UsedRange
        .Close 0
    End With
    Range("b:iv").Clear
    r = Cells(Rows.Count, 1).End(3).Row
    arr = [a1].Resize(r)
    'brr = Sheets(1).UsedRange
    r = 0
    For j = 1 To UBound(brr, 2)
        For i = 1 To UBound(arr)
            If arr(i, 1) <> brr(i, j) Then
                GoTo l1
            End If
        Next i
        r = r + 1
        For i = 1 To UBound(brr)
            brr(i, r) = brr(i, j)
        Next i
l1:
    Next j
    If r > 0 Then
        [b1].Resize(UBound(brr), r) = brr
    End If
    Application.ScreenUpdating = True
End Sub