复杂的多表汇总(难度有点大,做出来有分加哦)

libo5563

VBA不会，power query做一个，虽然是很早的提问了，但题目有点意思，思路就是3个4维的表格合并为一张一维表格再透视，做的时候才发现列的顺序和列的数量不固定，完全用power query将3张数据表合在一个表里做转换 目前M 语言的功力还达不到，只好手动转换每张数据表再合并，当有新的月份增加，及产品再有增加时还得到pq里调整，有点遗憾。

爱吃蜂蜜的狼

1. Sub huizong()
   
2. Dim sh As Worksheet, k, k1, ar(), r(), rr()
   
3. k1 = Sheet1.Range("c:c").Find("*", , , , , xlPrevious).Row
   
4. '=====================将总表中的省份和销售网点写书数组arr中
   
5. Sheet1.Range("d4:ai" & k1) = ""
   
6. arr = Sheet1.Range("b4:c" & k1)
   
7. For i = 1 To k1 - 3
   
8.       If arr(i, 1) = "" Then
   
9.       arr(i, 1) = arr(i - 1, 1)
   
10.       arr(i, 2) = arr(i, 1) & arr(i, 2)
    
11.       Else
    
12.       arr(i, 2) = arr(i, 1) & arr(i, 2)
    
13.       End If
    
14. Next
    
15. '======================将总表中的表头写入数组arr1中
    
16. arr1 = Sheet1.Range("d2:ai3")
    
17. For ii = 1 To UBound(arr1, 2)
    
18.       If arr1(1, ii) = "" Then
    
19.       arr1(1, ii) = arr1(1, ii - 1)
    
20.       arr1(2, ii) = arr1(1, ii) & arr1(2, ii)
    
21.       Else
    
22.       arr1(2, ii) = arr1(1, ii) & arr1(2, ii)
    
23.       End If
    
24. Next
    
25. '=======================定义数组ar大小与总表中需要输入的单元格范围相同
    
26. ReDim ar(1 To k1 - 3, 1 To 32)
    
27. '==============遍历工作簿的所有工作表（For Each sh In ThisWorkbook.Sheets）
    
28. For Each sh In ThisWorkbook.Sheets
    
29. '==============将非总表的省份和销售网点写入数组r,表头写入数组rr
    
30.        If sh.Name <> "总表" Then
    
31.           k = sh.Range("c:c").Find("*", , , , , xlPrevious).Row
    
32.           k2 = sh.Range("3:3").Find("*", , , , , xlPrevious).Column
    
33.           ReDim r(1 To k - 3, 1 To 2)
    
34.           ReDim rr(1 To 2, 1 To k2 - 3)
    
35.           r = sh.Range("b4:c" & k)
    
36.           rr = sh.Range(sh.Cells(2, 4), sh.Cells(3, k2))
    
37.           For i1 = 1 To UBound(r)
    
38.                 If r(i1, 1) = "" Then
    
39.                    r(i1, 1) = r(i1 - 1, 1)
    
40.                    r(i1, 2) = r(i1, 1) & r(i1, 2)
    
41.                    Else
    
42.                    r(i1, 2) = r(i1, 1) & r(i1, 2)
    
43.                 End If
    
44.           Next
    
45.           For i2 = 1 To UBound(rr, 2)
    
46.                 If rr(1, i2) = "" Then
    
47.                    rr(1, i2) = rr(1, i2 - 1)
    
48.                    rr(2, i2) = rr(1, i2) & rr(2, i2)
    
49.                    Else
    
50.                    rr(2, i2) = rr(1, i2) & rr(2, i2)
    
51.                 End If
    
52.           Next
    
53. '======================将符合要求的表的内容写入数组rrr()中
    
54.           rrr = sh.Range(sh.Cells(4, 4), sh.Cells(k, k2))
    
55. '=======以下通过4个循环的嵌套分别对比总表省份、销售网点、表头的编号、颜色
    
56.           For i3 = 1 To UBound(arr)
    
57.                 For i4 = 1 To UBound(r)
    
58.                       If arr(i3, 2) = r(i4, 2) Then
    
59.                          For i5 = 1 To UBound(arr1, 2)
    
60.                                For i6 = 1 To UBound(rr, 2)
    
61.                                      If arr1(2, i5) = rr(2, i6) Then
    
62. '===========将符合要求的数据进行累加写如事先声明号的数组ar数组中
    
63.                                         ar(i3, i5) = ar(i3, i5) + rrr(i4, i6)
    
64.                                       
    
65.                                      End If
    
66.                                Next
    
67.                          Next
    
68.                       End If
    
69.                 Next
    
70.           Next
    
71.        End If
    
72. Next
    
73. '=遍历完成所有的工作表后进行整体赋值（事先声明的数组与总表的区域单元格大小相同）
    
74. Sheet1.Range("d4:ai" & k1) = ar
    
75. End Sub
    

复制代码

jjmysjg

再留记号，谢谢

周侠仔

高手如云，我还需认真

周侠仔

ccwan 发表于 2010-1-21 08:34
我的代码其实很好理解，就是一般思路，一行行、一列列比对。
希望我的注释不会让大家糊涂了。

这个代码复制时是要把中文部份删除了吗

larer

可以用多重字典嵌套的方法

bl529700

做记号做记号

excelvlookup

有没有人试试，预先在模板上填上+-*/等运算符，按模板上的运算符进行汇总，而不是简单的累加？

lrh788

学习留痕！

lrh788

能否做到在总表中不事先设定表头，通过代码遍历除总表以外的所有工作表，自动将所有类型的表头写入总表表头再行汇总。