多个表格其中一项不能汇总，求帮助

wzd028

ykcbf1100 发表于 2024-8-3 14:41
改好了。

汇总我看了下应该没问题。

老师你好，代码修改后汇总表用途栏可以增加具体部门，但在H2至N2列新增加部门，如“保安部”后“预计月度用量合计”不能汇总数量（见附图）。能不能在H2至N2列内如果有新增加多个部门后“预计月度用量合计”可以汇总数量，不需要修改VBA，麻烦你修改一下，万分感谢！
  

ykcbf1100

wzd028 发表于 2024-8-3 23:42
老师你好，代码修改后汇总表用途栏可以增加具体部门，但在H2至N2列新增加部门，如“保安部”后“预计月 ...

改好了。。。

ykcbf1100

更新一下，解決增加部悶無法匯總的問題

1. Sub ykcbf()    '//2024.8.3    按部门汇总
   
2.     Dim arr, brr, d, p, f
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     b = [{1,2,3,4,5,6}]
   
10.     Set sh = ThisWorkbook.Sheets("采购计划表")
    
11.     c = sh.UsedRange.Find("*预计月度用量合计*", , , , , 1).Column
    
12.     p = ThisWorkbook.Path & ""
    
13.     ReDim brr(1 To 10000, 1 To 15)
    
14.     On Error Resume Next
    
15.     For Each f In fso.GetFolder(p).Files
    
16.         If LCase$(f.Name) Like "*.xls*" Then
    
17.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
18.                 '                fn = Split(fso.GetBaseName(f), "（")(1)
    
19.                 '                fn = Left(fn, Len(fn) - 1)
    
20.                 Set wb = Workbooks.Open(f, 0)
    
21.                 With wb.Sheets("月度使用计划表")
    
22.                     r = .Cells(.Rows.Count, 1).End(3).Row
    
23.                     arr = .[a1].Resize(r, 13)
    
24.                     fn = Split(.[a1].Value)(0)
    
25.                 End With
    
26.                 wb.Close False
    
27.                 For i = 3 To UBound(arr)
    
28.                     s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    
29.                     If s <> Empty Then
    
30.                         If Not d.Exists(s) Then
    
31.                             m = m + 1
    
32.                             d(s) = m
    
33.                             brr(m, 1) = m
    
34.                             For j = 2 To UBound(b)
    
35.                                 brr(m, j) = arr(i, b(j))
    
36.                             Next
    
37.                             brr(m, 7) = fn & "：" & arr(i, 12)
    
38.                             brr(m, c) = arr(i, 10)
    
39.                         Else
    
40.                             r = d(s)
    
41.                             brr(r, 7) = IIf(InStr(brr(r, 7), fn & "：" & arr(i, 12)), brr(r, 7), brr(r, 7) & "；" & fn & "：" & arr(i, 12))
    
42.                             brr(r, c) = brr(r, c) + arr(i, 10)
    
43.                         End If
    
44.                         d1(s & "|" & fn) = d1(s & "|" & fn) + arr(i, 10)
    
45.                     End If
    
46.                 Next
    
47.             End If
    
48.         End If
    
49.     Next
    
50.     With sh
    
51.         .UsedRange.Offset(3).ClearContents
    
52.         .[a4].Resize(m, 15) = brr
    
53.         .[a4].Resize(m, c).Borders.LineStyle = 1
    
54.         arr = .UsedRange
    
55.         For i = 4 To UBound(arr)
    
56.             Sum = 0
    
57.             For j = 8 To c - 1
    
58.                 s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(2, j)
    
59.                 If s <> Empty Then
    
60.                     If d1.Exists(s) Then
    
61.                         arr(i, j) = d1(s)
    
62.                         Sum = Sum + arr(i, j)
    
63.                     End If
    
64.                 End If
    
65.             Next
    
66.             arr(i, c) = Sum
    
67.         Next
    
68.         .UsedRange = arr
    
69.         ActiveWindow.DisplayZeros = False
    
70.     End With
    
71.     Application.ScreenUpdating = True
    
72.     MsgBox "运行完毕，共用时： " & Format(Timer - tm) & "秒！"
    
73. End Sub
    
74. 
    

复制代码

wzd028

ykcbf1100 发表于 2024-8-4 08:43
更新一下，解決增加部悶無法匯總的問題

谢谢您的热心相助，就是我想要的。