vba 按月份分到各个工作表中

answer6141

Sub 月份拆分()
Dim i, j, k As Integer
    For j = 2 To Sheets.Count
    Sheets(j).Range("a1:q1000").ClearContents
          For i = 2 To Sheet1.[a65536].End(xlUp).Row
              m = Month(Range("b" & i)) & "月"
              If m = Sheets(j).Name Then
                  Sheet1.Range("a1:k1").Copy Sheets(j).Range("A1")
                  k = Sheets(j).[a65536].End(xlUp).Row
                  Sheet1.Range("b" & i).EntireRow.Copy Sheets(j).Range("a" & k + 1)
              End If
          Next i
      Next j
End Sub

EXCELLMY

填充改拆分表

198801273815

answer6141 发表于 2019-12-18 01:22
Sub 月份拆分()
Dim i, j, k As Integer
    For j = 2 To Sheets.Count

表中3月 4月 5月 6月这几张表是我手动创建的，我现在想实现，根据总表中的月份自动创建，请问代码应该怎样写？

aman1516

198801273815 发表于 2019-12-18 00:59
表中3月 4月 5月 6月这几张表是我手动创建的，我现在想实现，根据总表中的月份自动创建，请问代码应该怎 ...

1. 
   
2. Private Sub CommandButton1_Click()
   
3. On Error Resume Next '
   
4. Dim arr, d, r, i, j, k, x
   
5. Set d = CreateObject("scripting.dictionary")
   
6. With Sheets("总表")
   
7.      arr = .[A1].CurrentRegion
   
8.      For i = 2 To UBound(arr)
   
9.          x = Month(arr(i, 2)) & "月"
   
10.          If Not d.exists(x) Then
    
11.             Set d(x) = Union(.[A1].Resize(1, 14), .Cells(i, 1).Resize(1, 14))
    
12.          Else
    
13.             Set d(x) = Union(d(x), .Cells(i, 1).Resize(1, 14))
    
14.          End If
    
15.      Next
    
16. End With
    
17. Call 删除工作表
    
18. dk = d.Keys: dt = d.Items
    
19. For i = 0 To UBound(dk)
    
20.     Worksheets.Add after:=Sheets(Sheets.Count)
    
21.     With ActiveSheet
    
22.          .Name = dk(i)
    
23.          dt(i).Copy .[A1]
    
24.     End With
    
25. Next
    
26. Sheets("总表").Activate
    
27. End Sub
    
28. 
    
29. Private Sub CommandButton2_Click()
    
30. Call 删除工作表
    
31. End Sub
    
32. 
    
33. Sub 删除工作表()
    
34.     Application.DisplayAlerts = False
    
35.     For Each Sh In Worksheets
    
36.         If Sh.Name <> "总表" Then Sh.Delete
    
37.     Next
    
38.     Application.DisplayAlerts = False
    
39. End Sub

复制代码

aman1516

详见附件：
代码.rar (37.76 KB, 下载次数: 29)

2019-12-18 21:17 上传

点击文件名下载附件

198801273815

aman1516 发表于 2019-12-18 21:17
详见附件：

好厉害，感谢大神，这正是我想要的结果

欧瑞博

aman1516 发表于 2019-12-17 22:59
详见附件：

请问老师：按月份只提取A,B,C列数据到月份表内，该如何修改。对vba自己不懂，恳请老师指定。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("总表")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
11.     arr = .Range("b1:b" & r)
    
12.     For i = 2 To UBound(arr)
    
13.       yf = Month(arr(i, 1)) & "月"
    
14.       If Not d.exists(yf) Then
    
15.         Set d(yf) = .Range("a1").Resize(1, c)
    
16.       End If
    
17.       Set d(yf) = Union(d(yf), .Cells(i, 1).Resize(1, c))
    
18.     Next
    
19.   End With
    
20.   For Each aa In d.keys
    
21.     On Error Resume Next
    
22.     Set ws = Worksheets(aa)
    
23.     If Err Then
    
24.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
25.       ws.Name = aa
    
26.     End If
    
27.     On Error GoTo 0
    
28.     With ws
    
29.       d(aa).Copy .Range("a1")
    
30.     End With
    
31.   Next
    
32.   Application.ScreenUpdating = True
    
33.   MsgBox "数据拆分完毕！"
    
34. End Sub
    

复制代码

chxw68

重新写一段供参考。