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

单身深蓝

附件中两个工作薄，一个是匹配源（含多个工作表），另一个是匹配结果，请老师抽空帮忙看看，谢谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Dim d As Object
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   With Worksheets("sheet1")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a2:b" & r)
    
12.     For i = 1 To UBound(arr)
    
13.       d(arr(i, 1)) = i
    
14.     Next
    
15.   End With
    
16.   mypath = ThisWorkbook.Path & ""
    
17.   myname = "匹配源表：多个工作表.xlsx"
    
18.   If Dir(mypath & myname) = "" Then
    
19.     MsgBox mypath & myname & "不存在！"
    
20.   End If
    
21.   Set wb = GetObject(mypath & myname)
    
22.   With wb
    
23.     For Each ws In .Worksheets
    
24.       With ws
    
25.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
26.         If r > 1 Then
    
27.           brr = .Range("a2:b" & r)
    
28.           For i = 1 To UBound(brr)
    
29.             If d.exists(brr(i, 1)) Then
    
30.               m = d(brr(i, 1))
    
31.               arr(m, 2) = brr(i, 2)
    
32.             End If
    
33.           Next
    
34.         End If
    
35.       End With
    
36.     Next
    
37.     .Close False
    
38.   End With
    
39.   With Worksheets("sheet1")
    
40.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
41.   End With
    
42. End Sub
    

复制代码

chxw68

详见附件。

单身深蓝

chxw68 发表于 2019-3-13 10:24
详见附件。

感谢老师 我试试！

一指禅62

1. 
   
2. Sub 导入数据()
   
3.     Dim d As Object, Wb As Workbook, Sh As Worksheet
   
4.     Dim arr, i&
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Rem 把单号装入字典
   
7.     arr = Sheet1.Range("A1").CurrentRegion
   
8.     For i = 2 To UBound(arr)
   
9.         d(arr(i, 1)) = ""
   
10.     Next
    
11.    
    
12.     Rem 打开指定工作簿，提取数据
    
13.     Set Wb = Workbooks.Open(ThisWorkbook.Path & "\匹配源表：多个工作表.xlsx")
    
14.     For Each Sh In Wb.Worksheets
    
15.         arr = Sh.Range("A1").CurrentRegion
    
16.         For i = 2 To UBound(arr)
    
17.             d(arr(i, 1)) = arr(i, 2)
    
18.         Next
    
19.     Next
    
20.     Wb.Close False
    
21. 
    
22.     Rem 把匹配结果输出到指定区域
    
23.     Sheet1.Range("A2:B65536").ClearContents
    
24.     Sheet1.Range("A2").Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.Items))
    
25.     Set d = Nothing
    
26.     Set Wb = Nothing
    
27.     Set Sh = Nothing
    
28. End Sub
    

复制代码

一指禅62

请楼主测试
论坛文件.rar (22.54 KB, 下载次数: 8)

2019-3-13 10:38 上传

点击文件名下载附件

单身深蓝

朱荣兴 发表于 2019-3-13 10:26
Sub 匹配() '' QQ:705664849  耕耘者
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].C ...

谢谢老师！

单身深蓝

朱荣兴 发表于 2019-3-13 10:26
Sub 匹配() '' QQ:705664849  耕耘者
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].C ...

老师，请问下匹配源数据如果中间有整行空白，该如何修改代码？

单身深蓝

朱荣兴 发表于 2019-3-13 10:26
Sub 匹配() '' QQ:705664849  耕耘者
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].C ...

我试了实际工作表，得不出结果，原因可能是数据源有空白行。