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

shiruiqiang

xpmiemiezhou

ykcbf1100 发表于 2024-2-21 21:47
修改后代码如下，增加代码通用性。

多谢大神，但是你第一个版本汇总表里部门名称是固定的，统计数据也是按汇总表设定的部门名称去匹配分表中的数据并提取，就是不能按数据多少自动增加行数而已，后面改的怎么汇总表的部门名称也变成自动提取了？能不能汇总表部门名称我自己手动输入固定不自动提取，这样我就可以按照我自己意愿来决定那些部门的数据提取那些不提取，同时做到提取的数据自动根据目标数据 的多少增加减少行数。我是新手，多次请教请别见怪哦，感谢大神不厌其烦的帮助。附件已上传，此附件是你帮我做的第一个版本，表格内我增加了类型列。

xpmiemiezhou

shiruiqiang 发表于 2024-2-21 22:04

多谢多谢！！

xpmiemiezhou

ykcbf1100 发表于 2024-2-21 21:47
修改后代码如下，增加代码通用性。

多谢大神，但是你第一个版本汇总表里部门名称是固定的，统计数据也是按汇总表设定的部门名称去匹配分表中的数据并提取，就是不能按数据多少自动增加行数而已，后面改的怎么汇总表的部门名称也变成自动提取了？能不能汇总表部门名称我自己手动输入固定不自动提取，这样我就可以按照我自己意愿来决定那些部门的数据提取那些不提取，同时做到提取的数据自动根据目标数据 的多少增加减少行数。我是新手，多次请教请别见怪哦。附件已上传，此附件是你帮我做的第一个版本。

xpmiemiezhou

cnmlgb9998 发表于 2024-2-21 14:36

还有就是增加工作表后，代码也不能用！

ykcbf1100

xpmiemiezhou 发表于 2024-2-21 23:38
多谢大神，但是你第一个版本汇总表里部门名称是固定的，统计数据也是按汇总表设定的部门名称去匹配分表中 ...

就目前你这表结构来看，你自己直接输入部门查询是不行的。要按部门查询，得另搞。我在下一个版本中更新吧。

ykcbf1100

代码更新。。。

1. Sub ykcbf()   '//2024.2.22
   
2.     Dim arr, d, zr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("考核汇总")
   
8.     For Each sht In ws.Sheets
   
9.         If sht.Name <> sh.Name Then
   
10.             With sht
    
11.                 fn = .Name
    
12.                 arr = .UsedRange
    
13.                 c = .Rows(2).Find("小计", , , , , 1).Column
    
14.             End With
    
15.             p4 = IIf(InStr(fn, "自查"), "自查", "")
    
16.             For i = 3 To UBound(arr)
    
17.                 s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & p4
    
18.                 d(s) = arr(i, c)
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     ReDim brr(1 To d.Count, 1 To 8)
    
23.     For Each k In d.keys
    
24.         m = m + 1
    
25.         b = Split(k, "|")
    
26.         brr(m, 1) = m
    
27.         brr(m, 2) = b(0)
    
28.         brr(m, 3) = b(1)
    
29.         brr(m, 4) = b(2)
    
30.         brr(m, 5) = b(3)
    
31.         brr(m, 6) = d(k)
    
32.         brr(m, 8) = b(4)
    
33.     Next
    
34.     On Error Resume Next
    
35.     With sh
    
36.         .UsedRange.Offset(2).UnMerge
    
37.         .UsedRange.Offset(2).Clear
    
38.         With .[a3].Resize(m, 8)
    
39.             .Value = brr
    
40.             .Borders.LineStyle = 1
    
41.             .HorizontalAlignment = xlCenter
    
42.             .VerticalAlignment = xlCenter
    
43.         End With
    
44.         .[a3].Resize(m, 8).Sort .[b3], 1
    
45.         zr = Array(1, 2, 7)
    
46.         Call 合并单元格(3, 2, zr)
    
47.         Call 合并单元格求和(3, 4, 6, 7)
    
48.     End With
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    
53. 
    
54. Function 合并单元格(r1, c, zr)  '//2024.2.22
    
55.     Application.DisplayAlerts = False
    
56.     r = ActiveSheet.Cells(Rows.Count, c).End(3).Row
    
57.     Dim rng As Range
    
58.     For i = r To r1 Step -1
    
59.         Set rng = ActiveSheet.Cells(i, c)
    
60.         Set Rng1 = rng.Offset(-1)
    
61.         If rng = Rng1 Then
    
62.             For x = 0 To UBound(zr)
    
63.                 ActiveSheet.Cells(i, zr(x)).Offset(-1).Resize(2).Merge
    
64.             Next
    
65.         End If
    
66.     Next
    
67.     Application.DisplayAlerts = True
    
68. End Function
    
69. 
    
70. Function 合并单元格求和(r1, col, c1, c)
    
71.     With ActiveSheet
    
72.         r = .Cells(Rows.Count, col).End(3).Row
    
73.         For i = r1 To r
    
74.             Set rng = .Cells(i, c)
    
75.             Sum = 0
    
76.             If rng.MergeCells = True Then
    
77.                 n = n + 1
    
78.                 .Cells(i, 1) = n
    
79.                 m = rng.MergeArea.Count
    
80.                 For x = 1 To m
    
81.                     Sum = Sum + ActiveSheet.Cells(i + x - 1, c1)
    
82.                 Next
    
83.                 rng.Value = Sum
    
84.                 i = i + m - 1
    
85.             Else
    
86.                 rng.Value = rng.Offset(, c1 - c).Value
    
87.             End If
    
88.         Next
    
89.     End With
    
90. End Function
    

复制代码

ykcbf1100

自选部门查询，供参考。。。

ykcbf1100

代码如下，按自选部门查询。

1. Sub ykcbf()   '//2024.2.22
   
2.     Dim arr, d, zr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("考核汇总")
   
8.     bm = sh.[j2].Value
   
9.     For Each sht In ws.Sheets
   
10.         If sht.Name <> sh.Name Then
    
11.             With sht
    
12.                 fn = .Name
    
13.                 arr = .UsedRange
    
14.                 c = .Rows(2).Find("小计", , , , , 1).Column
    
15.             End With
    
16.             p4 = IIf(InStr(fn, "自查"), "自查", "")
    
17.             For i = 3 To UBound(arr)
    
18.                 If InStr(bm, arr(i, 2)) Then
    
19.                     s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & p4
    
20.                     d(s) = arr(i, c)
    
21.                 End If
    
22.             Next
    
23.         End If
    
24.     Next
    
25.     ReDim brr(1 To d.Count, 1 To 8)
    
26.     For Each k In d.keys
    
27.         m = m + 1
    
28.         b = Split(k, "|")
    
29.         brr(m, 1) = m
    
30.         brr(m, 2) = b(0)
    
31.         brr(m, 3) = b(1)
    
32.         brr(m, 4) = b(2)
    
33.         brr(m, 5) = b(3)
    
34.         brr(m, 6) = d(k)
    
35.         brr(m, 8) = b(4)
    
36.     Next
    
37.     On Error Resume Next
    
38.     With sh
    
39.         .UsedRange.Offset(2).UnMerge
    
40.         .UsedRange.Offset(2).Clear
    
41.         With .[a3].Resize(m, 8)
    
42.             .Value = brr
    
43.             .Borders.LineStyle = 1
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.         End With
    
47.         .[a3].Resize(m, 8).Sort .[b3], 1
    
48.         zr = Array(1, 2, 7)
    
49.         Call 合并单元格(3, 2, zr)
    
50.         Call 合并单元格求和(3, 4, 6, 7)
    
51.     End With
    
52.     Set d = Nothing
    
53.     Application.ScreenUpdating = True
    
54.     MsgBox "OK！"
    
55. End Sub
    
56. 
    
57. Function 合并单元格(r1, c, zr)  '//2024.2.22
    
58.     Application.DisplayAlerts = False
    
59.     r = ActiveSheet.Cells(Rows.Count, c).End(3).Row
    
60.     Dim rng As Range
    
61.     For i = r To r1 Step -1
    
62.         Set rng = ActiveSheet.Cells(i, c)
    
63.         Set Rng1 = rng.Offset(-1)
    
64.         If rng = Rng1 Then
    
65.             For x = 0 To UBound(zr)
    
66.                 ActiveSheet.Cells(i, zr(x)).Offset(-1).Resize(2).Merge
    
67.             Next
    
68.         End If
    
69.     Next
    
70.     Application.DisplayAlerts = True
    
71. End Function
    
72. 
    
73. Function 合并单元格求和(r1, col, c1, c)
    
74.     With ActiveSheet
    
75.         r = .Cells(Rows.Count, col).End(3).Row
    
76.         For i = r1 To r
    
77.             Set rng = .Cells(i, c)
    
78.             Sum = 0
    
79.             If rng.MergeCells = True Then
    
80.                 n = n + 1
    
81.                 .Cells(i, 1) = n
    
82.                 m = rng.MergeArea.Count
    
83.                 For x = 1 To m
    
84.                     Sum = Sum + ActiveSheet.Cells(i + x - 1, c1)
    
85.                 Next
    
86.                 rng.Value = Sum
    
87.                 i = i + m - 1
    
88.             Else
    
89.                 rng.Value = rng.Offset(, c1 - c).Value
    
90.             End If
    
91.         Next
    
92.     End With
    
93. End Function
    
94. 
    

复制代码

xpmiemiezhou

ykcbf1100 发表于 2024-2-22 11:45
自选部门查询，供参考。。。

大神果然厉害，这都能搞定！可以根据J2单元格内预设的部门顺序提取吗？比如说部门1、部门2、部门3改成部门2、部门1、部门3后，提取顺序就按部门2先提取，再一次按顺序提取。还有就是 我新增一个别的工作表后代码就出错了，只能是存在这三个工作表才能用？