批量生成求助

1013182120

照着头条老师 做的  到最后不会了 论坛老大们看下

gwjkkkkk

要求写一下，模拟一下结果 ，不知道最后要达到什么样子。

chxw68

详见附件。

1013182120

chxw68 发表于 2024-4-9 18:56
详见附件。

牛  谢谢 老师

ykcbf1100

还是新写一个吧，看别人代码花费时间更多。

附件供参考。。。

ykcbf1100

参与一下。。。。

1. Sub ykcbf()  '//2024.4.9
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> "总表" And sht.Name <> "模板" Then
   
8.             sht.Delete
   
9.         End If
   
10.     Next
    
11.     With Sheets("总表")
    
12.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
13.         arr = .[a1].Resize(r, 16)
    
14.     End With
    
15.     For i = 2 To UBound(arr)
    
16.         s = arr(i, 15)
    
17.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
18.         d(s)(i) = i
    
19.     Next
    
20.     On Error Resume Next
    
21.     For Each k In d.keys
    
22.         m = 0
    
23.         Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
24.         Set sht = Sheets(Sheets.Count)
    
25.         ReDim brr(1 To 100, 1 To 9)
    
26.         With sht
    
27.             .Name = k
    
28.             .[j3] = k
    
29.             Sum = 0
    
30.             .DrawingObjects.Delete
    
31.             For Each kk In d(k).keys
    
32.                 m = m + 1
    
33.                 If m = 1 Then r = kk
    
34.                 .[j4] = arr(r, 11)
    
35.                 .[g4] = arr(r, 9)
    
36.                 .[c4] = arr(r, 12)
    
37.                 .[j20] = arr(r, 14)
    
38.                 For j = 1 To UBound(arr, 2)
    
39.                     brr(m, j) = arr(kk, j)
    
40.                 Next
    
41.                 brr(m, 9) = arr(kk, 16)
    
42.                 Sum = Sum + brr(m, 9)
    
43.             Next
    
44.             .[b6:b18].NumberFormatLocal = "@"
    
45.             .[i6:i18].NumberFormatLocal = "0%"
    
46.             .[b6].Resize(m, 9) = brr
    
47.             .[j19] = Sum
    
48.         End With
    
49.     Next
    
50.     Sheets("模板").Select
    
51.     Set d = Nothing
    
52.     Application.ScreenUpdating = True
    
53.     MsgBox "OK！"
    
54. End Sub
    

复制代码

1013182120

ykcbf1100 发表于 2024-4-9 20:04
参与一下。。。。

老师 很牛  能写道一张表里面吗  赞

ykcbf1100

1013182120 发表于 2024-4-9 20:20
老师 很牛  能写道一张表里面吗  赞

分成多张表应该更清楚，个人感觉都弄到一个表中去看数据也累。

1013182120

ykcbf1100 发表于 2024-4-9 20:22
分成多张表应该更清楚，个人感觉都弄到一个表中去看数据也累。

好吧  谢谢老师  赞 赞赞

yynrzwh

你的表名都对不上，改一下就好
新建 Microsoft Excel 工作表.zip (26.94 KB, 下载次数: 11)

2024-4-9 21:12 上传

点击文件名下载附件