按送货日期拆分生成新的工作表?

xus123

如题，请问各位老师，如何按送货日期拆分成新的工作表？
非常感谢！

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.19
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     p = ThisWorkbook.Path & ""
   
7.     Set sh = ThisWorkbook.Sheets("数据")
   
8.     For Each sht In Sheets
   
9.         If sht.Name <> sh.Name Then
   
10.             sht.Delete
    
11.         End If
    
12.     Next
    
13.     arr = sh.UsedRange
    
14.     For i = 2 To UBound(arr)
    
15.         If arr(i, 9) <> Empty Then
    
16.             s = Format(arr(i, 9), "yyyy-m-d")
    
17.             If Not d.Exists(s) Then
    
18.                 Set d(s) = CreateObject("scripting.dictionary")
    
19.             End If
    
20.             d(s)(i) = i
    
21.         End If
    
22.     Next i
    
23.     For Each k In d.keys
    
24.         sh.Copy after:=Sheets(Sheets.Count)
    
25.         Set sht = Sheets(Sheets.Count)
    
26.         m = 0
    
27.         ReDim brr(1 To d(k).Count, 1 To 10)
    
28.         With sht
    
29.             .DrawingObjects.Delete
    
30.             .UsedRange.Offset(d(k).Count + 2).Clear
    
31.             .Name = k
    
32.             For Each kk In d(k).keys
    
33.                 m = m + 1
    
34.                 brr(m, 1) = m
    
35.                 For j = 2 To UBound(arr, 2)
    
36.                     brr(m, j) = arr(kk, j)
    
37.                 Next
    
38.             Next
    
39.             .[a2].Resize(m, 9) = brr
    
40.             r = .Cells(Rows.Count, 1).End(3).Row
    
41.             .Cells(r + 1, 1).Resize(1, 9) = ""
    
42.             .Cells(r + 1, 2) = "合计"
    
43.             .Cells(r + 1, 7).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    
44.             .Cells(r + 2, 2) = "验收人："
    
45.             .Cells(r + 2, 7) = "送货人："
    
46.             .Range(.Cells(r + 1, 1), .Cells(r + 2, 9)).Interior.ColorIndex = 6
    
47.         End With
    
48.     Next k
    
49.     sh.Activate
    
50.     Set d = Nothing
    
51.     Application.DisplayAlerts = True
    
52.     Application.ScreenUpdating = True
    
53.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
54. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

xus123

非常感谢ykcbf1100老师的帮助！