分表

ddz79101

老师！我希望将总表中的日期列按月分为月表。谢谢

feilanga

................

fzxba

按日期中的月分表.zip (22.96 KB, 下载次数: 6)

2024-2-19 15:59 上传

点击文件名下载附件

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Sheets("原表").Select
    arr = Sheets("原表").[a1].CurrentRegion
    For j = 2 To UBound(arr)
        m = Month(arr(j, 1)) & ""
        If d.exists(m) Then
            Set d(m) = Union(d(m), Cells(j, 1))
        Else
            Set d(m) = Cells(j, 1)
        End If
    Next j
    For Each sh In Sheets
        If d.exists(sh.Name) Then
            d(sh.Name).EntireRow.Copy sh.Cells(Rows.Count, 1).End(3).Offset(1)
            d.Remove sh.Name
        End If
    Next
    For Each k In d.keys
        Sheets("原表").Copy after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = k
        Sheets(Sheets.Count).UsedRange.Offset(1).EntireRow.Delete
        d(k).EntireRow.Copy Sheets(Sheets.Count).[a2]
    Next k
    Application.ScreenUpdating = True
End Sub

liulang0808

按日期中的月分表.zip (19.24 KB, 下载次数: 30)

2024-2-19 16:02 上传

点击文件名下载附件

保留原来分表的数据。

saghj

不知道这样是否符合要求，没看懂11月份是什么情况

半百

参与一下

ykcbf1100

参与一下，经典字典嵌套一表拆分为多表。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.2.19
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("原表")
   
9.     For Each sht In Sheets
   
10.         If sht.Name <> sh.Name Then
    
11.             sht.Delete
    
12.         End If
    
13.     Next
    
14.     arr = sh.[a1].CurrentRegion
    
15.     For i = 2 To UBound(arr)
    
16.         s = Month(arr(i, 1))
    
17.         If Not d.Exists(s) Then
    
18.             Set d(s) = CreateObject("scripting.dictionary")
    
19.         End If
    
20.         d(s)(i) = i
    
21.     Next i
    
22.     For Each k In d.keys
    
23.         sh.Copy after:=Sheets(Sheets.Count)
    
24.         Set sht = Sheets(Sheets.Count)
    
25.         m = 0
    
26.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
27.         With sht
    
28.             .Name = k
    
29.             .UsedRange.Offset(d(k).Count + 1).Clear
    
30.             For Each kk In d(k).keys
    
31.                 m = m + 1
    
32.                 For j = 1 To UBound(arr, 2)
    
33.                     brr(m, j) = arr(kk, j)
    
34.                 Next
    
35.             Next
    
36.             .[a2].Resize(m, UBound(arr, 2)) = brr
    
37.             .[a1].Resize(m + 1, UBound(arr, 2)).Borders.LineStyle = 1
    
38.         End With
    
39.     Next k
    
40.     sh.Activate
    
41.     Set d = Nothing
    
42.     Application.DisplayAlerts = True
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
45. End Sub
    

复制代码

ddz79101

liulang0808 发表于 2024-2-19 16:02
保留原来分表的数据。

谢谢老师！运行目标达到。