求助按日期新建工作表拆分数据

879851984

已解决。感谢

ykcbf1100

总表按模板拆分为多表

更新一下，加个小计计算

ykcbf1100

。。。。。。

ykcbf1100

代码更新，加个小计

1. Sub ykcbf()   '//2024.7.31  总表按模板拆分为多表,加个小计
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each sht In Sheets
   
6.         If Val(sht.Name) Then sht.Delete
   
7.     Next
   
8.     With Sheets("申购记录")
   
9.         r = .Cells(Rows.Count, 6).End(3).Row
   
10.         c = .UsedRange.Columns.Count
    
11.         arr = .[a1].Resize(r, c)
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         s = FormatDateTime(arr(i, 1), 1)
    
15.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
16.         d(s)(i) = i
    
17.     Next
    
18.     On Error Resume Next
    
19.     For Each k In d.keys
    
20.         Sheets("模版").Copy After:=Sheets(Sheets.Count)
    
21.         Set sht = Sheets(Sheets.Count)
    
22.         m = 0
    
23.         With sht
    
24.             .[m2] = k
    
25.             .Name = k
    
26.             ReDim brr(1 To 1000, 1 To 14)
    
27.             For Each kk In d(k).keys
    
28.                 m = m + 1
    
29.                 For j = 2 To UBound(arr)
    
30.                     brr(m, j - 1) = arr(kk, j)
    
31.                 Next
    
32.             Next
    
33.             If m > 5 Then
    
34.                 For i = 1 To m - 5
    
35.                     .Cells(5 + i, 1).EntireRow.Insert
    
36.                 Next i
    
37.             End If
    
38.             .[a4].Resize(m, 14) = brr
    
39.             r = .Columns.Find("汇总").Row
    
40.             .Cells(r, "k") = Application.Sum(.Cells(4, "l").Resize(m))
    
41.         End With
    
42.     Next
    
43.     Sheets("申购记录").Activate
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "OK！"
    
46. End Sub
    
47. 
    

复制代码

879851984

ykcbf1100 发表于 2024-7-31 15:32
代码更新，加个小计

非常感谢，完美决绝。