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

chxw68

练习。。。

最爱咥面

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

最爱咥面

ykcbf1100 发表于 2024-7-25 19:43
参与一下。。。

老师，我再求教下，表格里我想加入横向求和，再程序里怎么加入啊。

ykcbf1100

最爱咥面 发表于 2024-7-26 13:11
老师，我再求教下，表格里我想加入横向求和，再程序里怎么加入啊。

加个行合计，改好了。。。

ykcbf1100

加个行合计

1. Sub ykcbf()   '//2024.7.26    多簿汇总
   
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.         End If
    
22.         d(arr(i, 2)) = arr(i, 1)
    
23.     Next
    
24.     On Error Resume Next
    
25.     For Each f In fso.GetFolder(p).Files
    
26.         fn = fso.GetBaseName(f)
    
27.         If Val(fn) Then
    
28.             m = m + 1
    
29.             rq = CDate("2024/" & Replace(Replace(fn, "号", ""), ".", "/"))
    
30.             brr(m, 1) = rq
    
31.             Set wb = Workbooks.Open(f, 0)
    
32.             For Each sht In wb.Sheets
    
33.                 With sht
    
34.                     arr = .UsedRange.Value
    
35.                     For i = 6 To UBound(arr)
    
36.                         If Val(arr(i, 1)) Then
    
37.                             If arr(i, 2) <> Empty Then
    
38.                                 s = arr(i, 2)
    
39.                                 If d.exists(s) Then arr(i, 8) = d(s)
    
40.                                 c = d(arr(i, 8))
    
41.                                 brr(m, c) = brr(m, c) + Val(arr(i, 7))
    
42.                             End If
    
43.                         End If
    
44.                     Next
    
45.                     .UsedRange.Value = arr
    
46.                 End With
    
47.             Next
    
48.             wb.Close 1
    
49.         End If
    
50.     Next
    
51.     m = m + 1
    
52.     brr(m, 1) = "合计"
    
53.     For j = 2 To n
    
54.         Sum = 0
    
55.         For i = 3 To m - 1
    
56.             Sum = Sum + brr(i, j)   '//求每列合计
    
57.         Next
    
58.         brr(m, j) = Sum
    
59.     Next
    
60.     n = n + 1
    
61.     brr(2, n) = "合计"
    
62.     For i = 3 To m
    
63.         Sum = 0
    
64.         For j = 2 To n - 1
    
65.             Sum = Sum + brr(i, j)   '//求每行合计
    
66.         Next
    
67.         brr(i, n) = Sum
    
68.     Next
    
69.     With sh
    
70.         .UsedRange.Clear
    
71.         .Cells.Interior.ColorIndex = 0
    
72.         .[a1].Resize(2, n).Interior.Color = 49407
    
73.         .[a3].Resize(m - 2, 1).Interior.Color = 5296274
    
74.         With .[a1].Resize(m, n)
    
75.             .Value = brr
    
76.             .Borders.LineStyle = 1
    
77.             .HorizontalAlignment = xlCenter
    
78.             .VerticalAlignment = xlCenter
    
79.             With .Font
    
80.                 .Name = "微软雅黑"
    
81.                 .Size = 11
    
82.             End With
    
83.         End With
    
84.         arr = .UsedRange
    
85.         .[a1].Resize(2).Merge
    
86.         .[b1].Resize(, n - 1).Merge
    
87.         .[a3].Resize(m - 3, n).Sort .[a3], 1
    
88.     End With
    
89.     Set d = Nothing
    
90.     Application.ScreenUpdating = True
    
91.     MsgBox "OK！"
    
92. End Sub
    

复制代码

最爱咥面

老师，为什么汇总后，每个日期的子表里，所有的函数链接都没有了，能不能汇总后保留子表的函数和链接。谢谢

最爱咥面

ykcbf1100 发表于 2024-7-26 13:45
加个行合计

老师，为什么汇总后，每个日期的子表里，所有的函数链接都没有了，能不能汇总后保留子表的函数和链接。谢谢

ykcbf1100

最爱咥面 发表于 2024-7-28 20:06
老师，为什么汇总后，每个日期的子表里，所有的函数链接都没有了，能不能汇总后保留子表的函数和链接。谢 ...

改一下，不改变分表结构。

ykcbf1100

改一下吧。。。

1. Sub ykcbf()   '//2024.7.28    多簿汇总
   
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.         End If
    
22.         d(arr(i, 2)) = arr(i, 1)
    
23.     Next
    
24.     On Error Resume Next
    
25.     For Each f In fso.GetFolder(p).Files
    
26.         fn = fso.GetBaseName(f)
    
27.         If Val(fn) Then
    
28.             m = m + 1
    
29.             rq = CDate("2024/" & Replace(Replace(fn, "号", ""), ".", "/"))
    
30.             brr(m, 1) = rq
    
31.             Set wb = Workbooks.Open(f, 0)
    
32.             For Each sht In wb.Sheets
    
33.                 With sht
    
34.                     arr = .UsedRange.Value
    
35.                     For i = 6 To UBound(arr)
    
36.                         If Val(arr(i, 1)) Then
    
37.                             If arr(i, 2) <> Empty Then
    
38.                                 s = arr(i, 2)
    
39.                                 If d.exists(s) Then stt = d(s)
    
40.                                 c = d(stt)
    
41.                                 brr(m, c) = brr(m, c) + Val(arr(i, 7))
    
42.                             End If
    
43.                         End If
    
44.                     Next
    
45.                   
    
46.                 End With
    
47.             Next
    
48.             wb.Close 1
    
49.         End If
    
50.     Next
    
51.     m = m + 1
    
52.     brr(m, 1) = "合计"
    
53.     For j = 2 To n
    
54.         Sum = 0
    
55.         For i = 3 To m - 1
    
56.             Sum = Sum + brr(i, j)   '//求每列合计
    
57.         Next
    
58.         brr(m, j) = Sum
    
59.     Next
    
60.     n = n + 1
    
61.     brr(2, n) = "合计"
    
62.     For i = 3 To m
    
63.         Sum = 0
    
64.         For j = 2 To n - 1
    
65.             Sum = Sum + brr(i, j)   '//求每行合计
    
66.         Next
    
67.         brr(i, n) = Sum
    
68.     Next
    
69.     With sh
    
70.         .UsedRange.Clear
    
71.         .Cells.Interior.ColorIndex = 0
    
72.         .[a1].Resize(2, n).Interior.Color = 49407
    
73.         .[a3].Resize(m - 2, 1).Interior.Color = 5296274
    
74.         With .[a1].Resize(m, n)
    
75.             .Value = brr
    
76.             .Borders.LineStyle = 1
    
77.             .HorizontalAlignment = xlCenter
    
78.             .VerticalAlignment = xlCenter
    
79.             With .Font
    
80.                 .Name = "微软雅黑"
    
81.                 .Size = 11
    
82.             End With
    
83.         End With
    
84.         arr = .UsedRange
    
85.         .[a1].Resize(2).Merge
    
86.         .[b1].Resize(, n - 1).Merge
    
87.         .[a3].Resize(m - 3, n).Sort .[a3], 1
    
88.     End With
    
89.     Set d = Nothing
    
90.     Application.ScreenUpdating = True
    
91.     MsgBox "OK！"
    
92. End Sub
    
93. 
    

复制代码

最爱咥面

ykcbf1100 发表于 2024-7-28 20:29
改一下吧。。。

太谢谢了。