按照固定模板将汇总数据批量生成工作表

z0ching

按照固定模板将汇总数据批量生成工作表,生成对应个工作表,工作表按照存货一一命名,求vba,谢谢

chengyunpan

我的批量软件可以单独生成文件，不是生成工作表。

ykcbf1100

我的电脑拆分时间约13秒。

ykcbf1100

1. Sub ykcbf()   '//2022.12.2
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr, d
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = Sheet1
   
7.     Dim tm: tm = Timer
   
8.     On Error Resume Next
   
9.     Set mb = Sheets("模板")
   
10.     For Each sht In Sheets
    
11.         If InStr(sht.Name, "汇总") = 0 And InStr(sht.Name, "模板") = 0 Then sht.Delete
    
12.     Next sht
    
13.     With sh
    
14.         r = .Cells(.Rows.Count, "b").End(xlUp).Row
    
15.         arr = .Range("a2:g" & r)
    
16.     End With
    
17.     ReDim brr(1 To UBound(arr), 1 To 11)
    
18.     For i = 1 To UBound(arr)
    
19.         s = arr(i, 3) & "|" & arr(i, 4)
    
20.         ss = arr(i, 1) & "|" & arr(i, 2)
    
21.         If Not d.exists(s) Then
    
22.             Set d(s) = CreateObject("Scripting.Dictionary")
    
23.         End If
    
24.         d(s)(ss) = Array(arr(i, 5), arr(i, 6), arr(i, 7))
    
25.     Next
    
26.     For Each aa In d.keys
    
27.         m = 0
    
28.         a = Split(aa, "|")
    
29.         Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    
30.         sht.Name = a(0)
    
31.         mb.Cells.Copy
    
32.         sht.Cells.Select
    
33.         ActiveSheet.Paste
    
34.         With sht
    
35.             .[a10:n1000].Clear
    
36.             .[d4] = a(0)
    
37.             .[k5] = a(1)
    
38.             For Each bb In d(aa).keys
    
39.                 m = m + 1
    
40.                 b = Split(bb, "|")
    
41.                 brr(m, 1) = b(0)
    
42.                 brr(m, 2) = b(1)
    
43.                 brr(m, 3) = d(aa)(bb)(0)
    
44.                 brr(m, 5) = d(aa)(bb)(1)
    
45.                 brr(m, 8) = d(aa)(bb)(2)
    
46.                 rc = rc + brr(m, 5)
    
47.                 cc = cc + brr(m, 8)
    
48.             Next
    
49.             .[a10].Resize(m, 10) = brr
    
50.             .[a10].Resize(m, 14).Borders.LineStyle = 1
    
51.             Dim hj(1 To 2)
    
52.             .[a10].Resize(m, 10).Sort .[a10], 1
    
53.             i = 10
    
54.             Do
    
55.                 If .Cells(i, 1) = .Cells(i + 1, 1) Then
    
56.                     hj(1) = hj(1) + .Cells(i, 5)
    
57.                     hj(2) = hj(2) + .Cells(i, 8)
    
58.                     .Cells(i, 3).Resize(1, 2).Merge
    
59.                     i = i + 1
    
60.                 Else
    
61.                     hj(1) = hj(1) + .Cells(i, 5)
    
62.                     hj(2) = hj(2) + .Cells(i, 8)
    
63.                     .Cells(i, 3).Resize(1, 2).Merge
    
64.                     i = i + 1
    
65.                     .Cells(i, 1).EntireRow.Insert    '//插入小计
    
66.                     .Cells(i, 3) = "本月合计"
    
67.                     .Cells(i, 3).Resize(1, 2).Merge
    
68.                     .Cells(i, 5) = hj(1)
    
69.                     .Cells(i, 8) = hj(2)
    
70.                     If .Cells(i, 5) = .Cells(i, 8) Then .Cells(i, 11) = "平"
    
71.                     i = i + 1
    
72.                     hj(1) = 0: hj(2) = 0
    
73.                 End If
    
74.             Loop While .Cells(i, 1) <> ""
    
75.             r = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
    
76.             .Cells(r, 3) = "本年累计"
    
77.             .Cells(i, 3).Resize(1, 2).Merge
    
78.             .Cells(r, 5) = rc
    
79.             .Cells(r, 8) = cc
    
80.             .[a10].Resize(r - 9, 14).Borders.LineStyle = 1
    
81.         End With
    
82.     Next
    
83.     sh.Activate
    
84.     Application.ScreenUpdating = True
    
85.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
86. End Sub
    

复制代码

ykcbf1100

80多行代码居然得不到楼主的一个回复。
好吧，有问题不要找我。

z0ching

ykcbf1100 发表于 2022-12-2 13:20

下午一直没机会摸电脑，现在才能上来看一眼，晚了回复很抱歉，拆分很快，代码非常好用，让老师费心了，非常感谢！

Sean_zhang810

赶快送花

andysky

支持一切格式，不需要为了格式变化重写代码，单击查看

可以生成工作表，可以生成工作簿，可以生成PDF
可以插入图片、可以插入二维码
应有应有........

SGD1

ykcbf1100 发表于 2022-12-2 15:25
80多行代码居然得不到楼主的一个回复。
好吧，有问题不要找我。

大神，膜拜

cnmlgb9998

ykcbf1100 发表于 2022-12-2 13:20

你这样直接在工作表单元格中进行读写操作，效率太低！！！！！！ 大神，用数组啊！