[已解决]根据送货明细自动生成月结明细与汇总表

文轩馨婷

.......
函数太慢了....
拜托各位VBA大侠....（具体看附件）
在此先谢过了！！！

月结汇总表要求：
1.根据月份（即E4）客户（即B5）在“送货明细”表中汇总引用满足此两条件的数据（注：月份和客户是变量）
解释汇总要求：相同月份相同客户相同一天的同一个送货单号的金额汇总
2.根据打印的一张A4纸的大小在最后一行合计“金额”列
3.在打印的页脚处有“客户确认”“复核”“制表人”
4.根据当前“头标”（即A1:L9）生成的新工作表名为“客户”（前2个字）&“月份”&“明细表”（即“宏星3月汇总表”）

月结明细表要求：
1.根据月份（即E4）客户（即B5）在“送货明细”表中引用满足此两条件的数据（注：月份和客户是变量）
2.根据打印的一张A4纸的大小在最后一行分别合计“数量”列和金额列
3.在打印的页脚处有“客户确认”“复核”“制表人”
4.根据当前“头标”（即A1:K9）生成的新工作表名为“客户”（前2个字）&“月份”&“明细表”（即“宏星3月明细表”）

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-28 16:45

1. Sub 月结明细表()
   
2.     yf = 3
   
3.     kh = "宏星印刷有限公司"
   
4.     arr = Sheets("送货明细表").[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 12)
   
6.     xrr = Array(3, 2, 4, 5, 6, 7, 8, 10, 11, 12, 13)
   
7.     For i = 3 To UBound(arr)
   
8.         If arr(i, 1) = kh And Month(arr(i, 2)) = yf Then
   
9.             n = n + 1
   
10.             For j = 0 To UBound(xrr)
    
11.                 brr(n, j + 1) = arr(i, xrr(j))
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     If n = 0 Then MsgBox "无记录": Exit Sub
    
16.     Sheets("月结明细表").Copy after:=Sheets(Sheets.Count)
    
17.     With ActiveSheet
    
18.         .[a10:k42].ClearContents
    
19.         .[a10].Resize(n, 12) = brr
    
20.         .[b5] = kh
    
21.         .[e4] = yf
    
22.         .Name = Left(kh, 2) & yf & "月明细表"
    
23.     End With
    
24. End Sub
    
25. 
    
26. Sub 月结汇总表()
    
27.     yf = 3
    
28.     kh = "宏星印刷有限公司"
    
29.     arr = Sheets("送货明细表").[a1].CurrentRegion
    
30.     ReDim brr(1 To UBound(arr), 1 To 7)
    
31.     Set d = CreateObject("scripting.dictionary")
    
32.     For i = 3 To UBound(arr)
    
33.         If arr(i, 1) = kh And Month(arr(i, 2)) = yf Then
    
34.             dh = arr(i, 3)
    
35.             If Not d.exists(dh) Then
    
36.                 n = n + 1
    
37.                 d(dh) = n
    
38.                 brr(n, 1) = n
    
39.                 brr(n, 2) = arr(i, 2)
    
40.                 brr(n, 4) = dh
    
41.             End If
    
42.             p = d(dh)
    
43.             brr(p, 7) = brr(p, 7) + arr(i, 12)
    
44.         End If
    
45.     Next
    
46.     If n = 0 Then MsgBox "无记录": Exit Sub
    
47.     Sheets("月结汇总表").Copy after:=Sheets(Sheets.Count)
    
48.     With ActiveSheet
    
49.         .[a10:L43].ClearContents
    
50.         .[a10].Resize(n, 7) = brr
    
51.         .[b5] = kh
    
52.         .[e4] = yf
    
53.         .Name = Left(kh, 2) & yf & "月汇总表"
    
54.     End With
    
55. End Sub

复制代码

跳转到最佳答案楼层

文轩馨婷

自己顶

文轩馨婷

{:091:}{:35:}

grf1973

做了一个汇总表，另一表原理一样的，自己搞定吧。
为简单计，月份客户直接在代码里赋值。如果要搞成输入或筛选型的，也自己搞定吧。
页脚已做在样表里。

1. Sub tt()
   
2.     yf = 3
   
3.     kh = "宏星印刷有限公司"
   
4.     arr = Sheets("送货明细表").[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 12)
   
6.     xrr = Array(3, 2, 4, 5, 6, 7, 8, 10, 11, 12, 13)
   
7.     For i = 3 To UBound(arr)
   
8.         If arr(i, 1) = kh Then
   
9.             n = n + 1
   
10.             For j = 0 To UBound(xrr)
    
11.                 brr(n, j + 1) = arr(i, xrr(j))
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     If n = 0 Then MsgBox "无记录": Exit Sub
    
16.     Sheets("月结明细表").Copy after:=Sheets(Sheets.Count)
    
17.     With ActiveSheet
    
18.         .[a10:k42].ClearContents
    
19.         .[a10].Resize(n, 12) = brr
    
20.         .[b5] = kh
    
21.         .[e4] = yf
    
22.         .Name = Left(kh, 2) & yf & "月明细表"
    
23.     End With
    
24. End Sub
    

复制代码

文轩馨婷

grf1973 发表于 2015-4-28 13:31
做了一个汇总表，另一表原理一样的，自己搞定吧。
为简单计，月份客户直接在代码里赋值。如果要搞成输入或 ...

老师，您做的是“明细表”不是汇总表

汇总表与明细表不一样！（汇总表需满足月份/客户的前提下又要满足相同“送货单号”的金额汇总，并且前面一列增加了一个“序列号”）

还有就是“明细表”中还忽略了时间问题（要同时满足月份与客户才从“送货明细”表中引用）

grf1973

1. Sub 月结明细表()
   
2.     yf = 3
   
3.     kh = "宏星印刷有限公司"
   
4.     arr = Sheets("送货明细表").[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 12)
   
6.     xrr = Array(3, 2, 4, 5, 6, 7, 8, 10, 11, 12, 13)
   
7.     For i = 3 To UBound(arr)
   
8.         If arr(i, 1) = kh And Month(arr(i, 2)) = yf Then
   
9.             n = n + 1
   
10.             For j = 0 To UBound(xrr)
    
11.                 brr(n, j + 1) = arr(i, xrr(j))
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     If n = 0 Then MsgBox "无记录": Exit Sub
    
16.     Sheets("月结明细表").Copy after:=Sheets(Sheets.Count)
    
17.     With ActiveSheet
    
18.         .[a10:k42].ClearContents
    
19.         .[a10].Resize(n, 12) = brr
    
20.         .[b5] = kh
    
21.         .[e4] = yf
    
22.         .Name = Left(kh, 2) & yf & "月明细表"
    
23.     End With
    
24. End Sub
    
25. 
    
26. Sub 月结汇总表()
    
27.     yf = 3
    
28.     kh = "宏星印刷有限公司"
    
29.     arr = Sheets("送货明细表").[a1].CurrentRegion
    
30.     ReDim brr(1 To UBound(arr), 1 To 7)
    
31.     Set d = CreateObject("scripting.dictionary")
    
32.     For i = 3 To UBound(arr)
    
33.         If arr(i, 1) = kh And Month(arr(i, 2)) = yf Then
    
34.             dh = arr(i, 3)
    
35.             If Not d.exists(dh) Then
    
36.                 n = n + 1
    
37.                 d(dh) = n
    
38.                 brr(n, 1) = n
    
39.                 brr(n, 2) = arr(i, 2)
    
40.                 brr(n, 4) = dh
    
41.             End If
    
42.             p = d(dh)
    
43.             brr(p, 7) = brr(p, 7) + arr(i, 12)
    
44.         End If
    
45.     Next
    
46.     If n = 0 Then MsgBox "无记录": Exit Sub
    
47.     Sheets("月结汇总表").Copy after:=Sheets(Sheets.Count)
    
48.     With ActiveSheet
    
49.         .[a10:L43].ClearContents
    
50.         .[a10].Resize(n, 7) = brr
    
51.         .[b5] = kh
    
52.         .[e4] = yf
    
53.         .Name = Left(kh, 2) & yf & "月汇总表"
    
54.     End With
    
55. End Sub

复制代码