如何使用代码实现 根据汇总表中B列部门名称，提取其他表中内容

xpmiemiezhou

请大神帮忙，如图：如何使用代码实现 根据考核汇总表中B列部门名称，查找上级考核工作表和自查工作表中对应部门名称的考核内容、责任人、金额内容并按选后顺序提取到汇总表中？并且在汇总表备注栏自动判断是否是自查。（本人只能使用Excel2007版）

shiruiqiang

需要字典嵌套。但是万一超过5条怎么办？

shiruiqiang

按照你的要求，可以少写几句

半百

请测试

ykcbf1100

代码更新一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.20
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     Set Sh = ws.Sheets("考核汇总")
   
7.     For Each sht In ws.Sheets
   
8.         If sht.Name <> Sh.Name Then
   
9.             With sht
   
10.                 r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
11.                 fn = .Name
    
12.                 arr = .[a1].Resize(r, 5)
    
13.             End With
    
14.             p4 = IIf(InStr(fn, "自查"), "自查", "")
    
15.             For i = 3 To UBound(arr)
    
16.                 s = arr(i, 2): ss = arr(i, 4)
    
17.                 If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
18.                 d(s)(ss) = Array(arr(i, 3), arr(i, 4), arr(i, 5), p4)
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     With Sh
    
23.         arr = .UsedRange
    
24.         For i = 3 To UBound(arr) Step 5
    
25.             s = arr(i, 2)
    
26.             For Each k In d.keys
    
27.                 x = 0
    
28.                 If s = k Then
    
29.                     For Each kk In d(k).keys
    
30.                         x = x + 1
    
31.                         .Cells(i + x - 1, 4) = kk
    
32.                         .Cells(i + x - 1, 3) = d(k)(kk)(0)
    
33.                         .Cells(i + x - 1, 5) = d(k)(kk)(2)
    
34.                         .Cells(i + x - 1, 7) = d(k)(kk)(3)
    
35.                     Next
    
36.                 Else
    
37.                     .Cells(i + x - 1, 4) = ""
    
38.                     .Cells(i + x - 1, 3) = ""
    
39.                     .Cells(i + x - 1, 5) = ""
    
40.                     .Cells(i + x - 1, 7) = ""
    
41.                 End If
    
42.             Next
    
43.         Next
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    
49. 
    

复制代码

xpmiemiezhou

shiruiqiang 发表于 2024-2-20 14:29
按照你的要求，可以少写几句

5行之后的就不能提取了？

xpmiemiezhou

ykcbf1100 发表于 2024-2-20 18:58
代码更新一下。。。

有些部门多几行数据就统计不出来了

xpmiemiezhou

半百 发表于 2024-2-20 16:32
请测试

要是在金额前面增加一列类型就统计不出来了，代码要如何修改？代码能附上说明吗？这样方便我后期学习和修改，谢谢！！！

shiruiqiang

xpmiemiezhou 发表于 2024-2-20 21:51
5行之后的就不能提取了？

n=n+5-dic(aa).count删除就行