求vba【跨sheet 遍历查询】跨多sheet查询

于恒

如图，
如附件，
求VBA代码，
遍历查询后面的sheet，
填充到第一个sheet（目标表）中，

扑腾

坛里类似的例子很多的，搜“跨工作簿”就行

ykcbf1100

参与一下。。。

ykcbf1100

感觉比较麻烦，每个表要单独处理。

1. Sub ykcbf()   '//2024.7.25
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("目标表")
   
5.     On Error Resume Next
   
6.     With Sheets("元数据1-办学层次")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         arr = .[a1].Resize(r, 2)
   
9.     End With
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 1) & "|" & arr(1, 2)
    
12.         d(s) = arr(i, 2)
    
13.     Next
    
14.     With Sheets("元数据2-选科要求")
    
15.         r = .Cells(Rows.Count, 1).End(3).Row
    
16.         arr = .[a1].Resize(r, 4)
    
17.     End With
    
18.     For i = 2 To UBound(arr)
    
19.         s = arr(i, 1) & "|" & arr(i, 3) & "|" & arr(1, 4)
    
20.         d(s) = arr(i, 4)
    
21.     Next
    
22.     With Sheets("元数据3-招生计划")
    
23.         r = .Cells(Rows.Count, 1).End(3).Row
    
24.         arr = .[a1].Resize(r, 55)
    
25.     End With
    
26.     For i = 2 To UBound(arr)
    
27.         s = arr(i, 3) & "|" & arr(i, 4) & "|" & arr(1, 5)
    
28.         d(s) = arr(i, 5)
    
29.     Next
    
30.     With sh
    
31.         r = .Cells(Rows.Count, 1).End(3).Row
    
32.         c = .UsedRange.Columns.Count
    
33.         arr = .[a1].Resize(r, c)
    
34.         .[d2:g1000] = ""
    
35.         For i = 2 To r
    
36.             s = arr(i, 3) & "|" & arr(1, 4)
    
37.             If d.exists(s) Then
    
38.                 arr(i, 4) = d(s)
    
39.             End If
    
40.             For j = 5 To c
    
41.                 s = arr(i, 3) & "|" & arr(i, 2) & "|" & arr(1, j)
    
42.                 If d.exists(s) Then
    
43.                     arr(i, j) = d(s)
    
44.                 End If
    
45.             Next
    
46.         Next
    
47.         .[a1].Resize(r, c) = arr
    
48.     End With
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    

复制代码

于恒

ykcbf1100 发表于 2024-7-25 13:02
感觉比较麻烦，每个表要单独处理。

亲测好使，我再逐行研究一下句法，稍等，有问题我再留言，请教您