求助：多个工作表匹配数据，请老师帮忙看看，谢谢！

单身深蓝

一指禅62 发表于 2019-3-13 10:38
请楼主测试

感谢！老师把所有单号都列出来，我不好处理，因为数据量太大咯。

一指禅62

单身深蓝 发表于 2019-3-13 13:53
感谢！老师把所有单号都列出来，我不好处理，因为数据量太大咯。

Sub 导入数据()
    Dim d As Object, Wb As Workbook, Sh As Worksheet
    Dim arr, i&
    Set d = CreateObject("Scripting.Dictionary")
    Rem 把单号装入字典
    arr = Sheet1.Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = ""
    Next

    Rem 打开指定工作簿，提取数据
    Application.ScreenUpdating = False
    Set Wb = Workbooks.Open(ThisWorkbook.Path & "\匹配源表：多个工作表.xlsx")
    For Each Sh In Wb.Worksheets
        arr = Sh.Range("A1").CurrentRegion
        For i = 2 To UBound(arr)
            If d.Exists(arr(i, 1)) Then d(arr(i, 1)) = arr(i, 2)
        Next
    Next
    Wb.Close False

    Rem 把匹配结果输出到指定区域
    Sheet1.Range("B2:B65536").ClearContents
    Sheet1.Range("A2").Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.Items))
    Application.ScreenUpdating = True
    Set d = Nothing
    Set Wb = Nothing
    Set Sh = Nothing
End Sub

单身深蓝

已解决，谢谢老师们！