获取多表信息

zllyyz

各大神，VBA小白卡在数组输出这里了（输出时只显示最后一个表的内容），请解惑，谢谢

gwjkkkkk

建议楼主上传附件，模拟结果。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.18
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             With sht
   
8.                 fn = .Name
   
9.                 r = .Cells(Rows.Count, 1).End(3).Row
   
10.                 arr = .Range("a6:v" & r)
    
11.                 If Not d.exists(fn) Then Set d(fn) = CreateObject("Scripting.Dictionary")
    
12.                 d(fn)("标题0") = .[a4]
    
13.                 d(fn)(arr(1, 1)) = arr(1, 2)
    
14.                 d(fn)(arr(2, 1)) = arr(2, 2)
    
15.                 d(fn)(arr(3, 1)) = arr(3, 2)
    
16.                 d(fn)(arr(1, 12)) = arr(1, 13)
    
17.                 d(fn)(arr(2, 12)) = arr(2, 13)
    
18.                 d(fn)(arr(3, 12)) = arr(3, 13)
    
19.                 d(fn)(arr(1, 21)) = arr(1, 22)
    
20.                 d(fn)(arr(2, 21)) = arr(2, 22)
    
21.                 d(fn)(arr(3, 21)) = arr(3, 22)
    
22.             End With
    
23.         End If
    
24.     Next
    
25.     With sh
    
26.         .[a6:j1000] = ""
    
27.         .[j6].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
28.         arr = .[a5].Resize(d.Count + 1, 10)
    
29.         For i = 2 To UBound(arr)
    
30.             For j = 1 To UBound(arr, 2) - 1
    
31.                 s = arr(i, 10)
    
32.                 If d.exists(s) Then
    
33.                     arr(i, j) = d(s)(arr(1, j))
    
34.                 End If
    
35.             Next
    
36.         Next
    
37.         .[a5].Resize(d.Count + 1, 10) = arr
    
38.         .[a5].Resize(d.Count + 1, 10).Borders.LineStyle = 1
    
39.     End With
    
40.     Set d = Nothing
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码

ykcbf1100

一会儿功夫，附件不见了？

我代码写好了，还是上传一下吧。

zllyyz

ykcbf1100 发表于 2024-1-18 19:28
一会儿功夫，附件不见了？

我代码写好了，还是上传一下吧。

脑袋突然卡了就发了个求助帖，后面想通了不知道怎么删帖就这样了，哈哈哈 ，谢谢老师

zllyyz

gwjkkkkk 发表于 2024-1-18 18:55
建议楼主上传附件，模拟结果。。。

脑袋突然卡了就发了个求助帖，后面想通了不知道怎么删帖就这样了，哈哈哈 ，谢谢老师

gwjkkkkk

ykcbf1100 发表于 2024-1-18 19:25
参与一下。。。

还是你草爷你手脚快。。。