怎么从每日清单数据按类别进行每日汇总

最爱咥面

又又又又要麻烦各位老师了，在此先谢谢了！！！！
怎么从每日清单数据按类别进行每日汇总

Onemeter

https://club.excelhome.net/thread-1698013-1-1.html
可以参考这个

wengjl

看了一下，你每日汇总表上的类别，与某天的表上的商品名称 ，二者没有一致性的，是无法统计的

ykcbf1100

你类别还搞成二个啊，你先统一一下啊，不然，无法汇总的。这个基础表和汇总表要对应的。先搞好这个，再重新上传附件吧，不然，别人不可能下手的。

最爱咥面

好的，我改下表

ykcbf1100

最爱咥面 发表于 2024-7-25 17:43
好的，我改下表

估计差不多吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.25    多簿汇总
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     p = ThisWorkbook.Path & ""
   
7.     f = p & "\价格表.xlsx"
   
8.     Set sh = ThisWorkbook.Sheets("每日汇总")
   
9.     Set wb = Workbooks.Open(f, 0)
   
10.     arr = wb.Sheets(1).UsedRange
    
11.     wb.Close 0
    
12.     ReDim brr(1 To UBound(arr), 1 To 100)
    
13.     m = 2: n = 1
    
14.     brr(1, 1) = "日期": brr(1, 2) = arr(1, 1)
    
15.     For i = 2 To UBound(arr)
    
16.         s = arr(i, 1)
    
17.         If Not d.exists(s) Then
    
18.             n = n + 1
    
19.             d(s) = n
    
20.             brr(2, n) = s
    
21.             d(arr(i, 2)) = arr(i, 1)
    
22.         End If
    
23.     Next
    
24.     t = d.items
    
25.     On Error Resume Next
    
26.     For Each f In fso.GetFolder(p).Files
    
27.         fn = fso.GetBaseName(f)
    
28.         If Val(fn) Then
    
29.             m = m + 1
    
30.             rq = CDate("2024/" & Replace(Replace(fn, "号", ""), ".", "/"))
    
31.             brr(m, 1) = rq
    
32.             Set wb = Workbooks.Open(f, 0)
    
33.             For Each sht In wb.Sheets
    
34.                 With sht
    
35.                     arr = .UsedRange.Value
    
36.                     For i = 6 To UBound(arr)
    
37.                         If Val(arr(i, 1)) Then
    
38.                             If arr(i, 2) <> Empty Then
    
39.                                 s = arr(i, 2)
    
40.                                 If d.exists(s) Then arr(i, 8) = d(s)
    
41.                                 c = d(arr(i, 8))
    
42.                                 brr(m, c) = brr(m, c) + Val(arr(i, 7))
    
43.                             End If
    
44.                         End If
    
45.                     Next
    
46.                     .UsedRange.Value = arr
    
47.                 End With
    
48.             Next
    
49.             wb.Close 1
    
50.         End If
    
51.     Next
    
52.     m = m + 1
    
53.     brr(m, 1) = "合计"
    
54.     For j = 2 To n
    
55.         Sum = 0
    
56.         For i = 3 To m - 1
    
57.             Sum = Sum + brr(i, j)   '//求每列合计
    
58.         Next
    
59.         brr(m, j) = Sum
    
60.     Next
    
61.     With sh
    
62.         .UsedRange.Clear
    
63.         .Cells.Interior.ColorIndex = 0
    
64.         .[a1].Resize(2, n).Interior.Color = 49407
    
65.         .[a3].Resize(m - 2, 1).Interior.Color = 5296274
    
66.         With .[a1].Resize(m, n)
    
67.             .Value = brr
    
68.             .Borders.LineStyle = 1
    
69.             .HorizontalAlignment = xlCenter
    
70.             .VerticalAlignment = xlCenter
    
71.             With .Font
    
72.                 .Name = "微软雅黑"
    
73.                 .Size = 11
    
74.             End With
    
75.         End With
    
76.         arr = .UsedRange
    
77.         .[a1].Resize(2).Merge
    
78.         .[b1].Resize(, n - 1).Merge
    
79.     End With
    
80.     Set d = Nothing
    
81.     Application.ScreenUpdating = True
    
82.     MsgBox "OK！"
    
83. End Sub
    

复制代码

14820103

数据太多无法验证，自行校对。

chxw68

练习。。。

最爱咥面

谢谢各位老师，太谢谢了。