一个复杂的多表汇总，请大神帮忙

1823824221

一个复杂的多表汇总，请大神帮忙

3190496160

问题不难，但是，要把你的需求都完成，恐怕不是一时之功哟，呵呵

microyip

http://club.excelhome.net/thread-1310803-1-1.html 多表多工作簿汇总，参考变通一下

liulang0808

1. Sub 按钮1_Click()
   
2.     Dim crr()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dd = CreateObject("scripting.dictionary")
   
5.     Set fso = CreateObject("scripting.filesystemobject")
   
6. 
   
7.     Application.ScreenUpdating = False
   
8.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
9.         If InStr(f.Name, "每日报表") = 0 Then
   
10.             With Workbooks.Open(f)
    
11.                 arr = .Sheets(1).UsedRange
    
12.                 .Close False
    
13.             End With
    
14.             d.RemoveAll
    
15.             dd.RemoveAll
    
16.             For j = 2 To UBound(arr)
    
17.                 If Len(arr(j, 2)) > 0 Then
    
18.                     str1 = Left(arr(j, 7), 2) & "@#$@" & arr(j, 2) & "@#$@" & arr(j, 3) & "@#$@" & arr(j, 4)
    
19.                     d(str1) = d(str1) + arr(j, 5)
    
20.                     dd(str1) = dd(str1) + arr(j, 6)
    
21.                 End If
    
22.             Next j
    
23.             
    
24.             For Each sht In ThisWorkbook.Sheets
    
25.                 brr = Split(sht.Name, "、")
    
26.                 ReDim crr(1 To d.Count, 1 To 5)
    
27.                 r = 0
    
28.                 For x = 0 To d.Count - 1
    
29.                     
    
30.                     str1 = d.keys()(x)
    
31.                     For Z = 0 To UBound(brr)
    
32.                         If Left(str1, 2) = brr(Z) Then
    
33.                             arr = Split(str1, "@#$@")
    
34.                             r = r + 1
    
35.                             crr(r, 1) = arr(1)
    
36.                             crr(r, 2) = arr(2)
    
37.                             crr(r, 3) = arr(3)
    
38.                             crr(r, 4) = d(str1)
    
39.                             crr(r, 5) = dd(str1)
    
40.                         End If
    
41.                     Next Z
    
42.                 Next x
    
43.                 For i = 1 To r
    
44.                     For j = i + 1 To r
    
45.                         If crr(j, 5) > crr(i, 5) Then
    
46.                         For x = 1 To 5
    
47.                             tmp = crr(i, x)
    
48.                             crr(i, x) = crr(j, x)
    
49.                             crr(j, x) = tmp
    
50.                         Next x
    
51.                         End If
    
52.                     Next j
    
53.                 Next i
    
54.                 If r > 0 Then
    
55.                     nm = Left(f.Name, 2)
    
56.                     If nm = "总店" Then
    
57.                         sht.[b4].Resize(WorksheetFunction.Min(r, 15), 5) = crr
    
58.                     Else
    
59.                         For x = 8 To sht.UsedRange.Columns.Count Step 6
    
60.                             ww = Left(sht.Cells(2, x), 2)
    
61.                             If ww = nm Then
    
62.                                 sht.Cells(4, x).Resize(WorksheetFunction.Min(r, 15), 5) = crr
    
63.                                 Exit For
    
64.                             End If
    
65.                         Next
    
66.                     End If
    
67.                 End If
    
68.             Next sht
    
69.             
    
70.         End If
    
71.     Next f
    
72.     Application.ScreenUpdating = True
    
73. End Sub

复制代码

liulang0808

楼主的表格不是很规范。附件供参考

1823824221

liulang0808 发表于 2020-2-20 18:20
楼主的表格不是很规范。附件供参考

感谢您的帮助，明天试试:

chxw68

详见附件。

1823824221

liulang0808 发表于 2020-2-20 18:20
楼主的表格不是很规范。附件供参考

最后一个工作表里多了一个汇总， 如果我把这三个工作表里都加上那个汇总，怎么改代码，麻烦帮我看看

1823824221

chxw68 发表于 2020-2-20 20:22
详见附件。

谢谢帮忙，但表的格式发生的变化，只有这类别的按金额排名的15个，

chxw68

主观臆断，把问题想复杂了。