VBA实现多子表数据透视般的汇总

YU-forever27

求各位老师帮助，附件中，在数据汇总表子表中，按表头内容汇总其他子表数据并求和，且表头是动态不规则的，显示效果为数据汇总表上数据。小弟接触VBA不久，就只能实现简单的多子表求和显示，有条件的求和仍然是一个大问题，求各位老师帮忙实现此功能，谢谢。

shiruiqiang

YU-forever27

shiruiqiang 发表于 2024-7-2 07:25

感谢老师，但是如果我表头变更的话，统计的数据不能按照变更的项进行统计

shiruiqiang

说实话，那是你个人理想的办法。
否则，字典怎么定义，数值是否可以去重汇总？
具体修改，自己照葫芦画瓢一样写吧

shiruiqiang

ykcbf1100

练个手，多表排重汇总，分表字段位置不固定

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.9   多表排重汇总,分表字段名位置不固定
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("数据汇总表")
   
6.     ReDim brr(1 To 10000, 1 To 6)
   
7.     With sh
   
8.         For j = 1 To 6
   
9.             s = .Cells(1, j)
   
10.             d1(s) = j
    
11.         Next
    
12.     End With
    
13.     On Error Resume Next
    
14.     For Each sht In ThisWorkbook.Sheets
    
15.         If sht.Name <> sh.Name Then
    
16.             With sht
    
17.                 r = .Cells(Rows.Count, 1).End(3).Row
    
18.                 c = .UsedRange.Columns.Count
    
19.                 arr = .[a1].Resize(r, c)
    
20.                 fn = .Name
    
21.             End With
    
22.             ReDim zrr(1 To 5)
    
23.             For x = 1 To 5
    
24.                 For j = 1 To UBound(arr, 2)
    
25.                     If d1(arr(1, j)) = x Then
    
26.                         zrr(x) = j
    
27.                         Exit For
    
28.                     End If
    
29.                 Next
    
30.             Next
    
31.             For i = 2 To UBound(arr)
    
32.                 s = arr(i, zrr(1)) & "|" & arr(i, zrr(2)) & "|" & arr(i, zrr(3))
    
33.                 If Not d.exists(s) Then
    
34.                     m = m + 1
    
35.                     d(s) = m
    
36.                     brr(m, 6) = fn
    
37.                     For k = 1 To 5
    
38.                         brr(m, k) = arr(i, zrr(k))
    
39.                     Next
    
40.                 Else
    
41.                     r = d(s)
    
42.                     brr(r, 4) = brr(r, 4) + arr(i, zrr(4))
    
43.                     brr(r, 5) = brr(r, 5) + arr(i, zrr(5))
    
44.                 End If
    
45.             Next
    
46.         End If
    
47.     Next
    
48.     With sh
    
49.         .UsedRange.Offset(1).Clear
    
50.         With .[a2].Resize(m, 6)
    
51.             .Value = brr
    
52.             .Borders.LineStyle = 1
    
53.             .HorizontalAlignment = xlCenter
    
54.             .VerticalAlignment = xlCenter
    
55.         End With
    
56.     End With
    
57.     Set d = Nothing
    
58.     Set d1 = Nothing
    
59.     Application.ScreenUpdating = True
    
60.     MsgBox "OK！"
    
61. End Sub
    

复制代码