数据按条件拆分成新表

hermit013434

目的：需要把报表中的数据先按月拆分成新工作表，后将各月数据复制粘贴到对应月份的表中。目前拆分的代码已经完成，复制粘贴数据的代码运行有问题，请大侠们帮忙看下问题出在哪，如何解决。

3190496160

你的代码整体思路欠佳，拆分问题，可以去看看这个帖子，下载就能用
Excel 灵活拆分工具-ExcelVBA程序开发-ExcelHome技术论坛 - http://club.excelhome.net/thread-1520853-1-1.html

gxx75

写 的 有 点 乱
Sub 水一个()
Dim arr, d, ar()
Dim x%, y%, z%, n%
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For x = 2 To UBound(arr)
d(arr(x, 5)) = d(arr(x, 5)) + 1
Next
k = d.keys
it = d.items
For y = 0 To d.Count - 1
  For x = 2 To UBound(arr)
  ReDim Preserve ar(1 To it(0), 1 To 6)
  If arr(x, 5) = k(y) Then
    n = n + 1
      For z = 1 To 6
      ar(n, z) = arr(x, z)
      Next
   End If
  Next
  Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
  sh.Name = k(y)
  Sheets("报表").Range("a1:f1").Copy sh.Range("a1")
  sh.Range("a2").Resize(it(0), 6) = ar
  n = 0
  Erase ar
Next
End Sub

1055751654

1. Option Explicit
   
2. Sub 玩玩()
   
3. Dim d As Object
   
4. Dim arr, q As Integer
   
5. Dim rng, sh As Worksheet
   
6. Dim w%, e%, r&
   
7. Set d = CreateObject("scripting.dictionary")
   
8. With Worksheets("报表")
   
9. arr = .Range("a1").CurrentRegion
   
10.     For q = 2 To UBound(arr)
    
11.     d(arr(q, 5)) = ""
    
12.     Next q
    
13.     For Each rng In d.keys
    
14.     For w = 2 To UBound(arr)
    
15.         If .Cells(w, 5).Value = rng Then
    
16.         r = r + 1
    
17.         For e = 1 To UBound(arr, 2)
    
18.         arr(r, e) = .Cells(w, e).Value
    
19.         Next
    
20.     End If
    
21. Next
    
22. Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
    
23. sh.Name = rng
    
24. Worksheets("报表").Rows(1).Copy Worksheets(sh.Name).Range("a1")
    
25. Worksheets(sh.Name).[a2].Resize(r, UBound(arr, 2)) = arr
    
26. r = 0
    
27. Next rng
    
28. End With
    
29. End Sub
    

复制代码

hermit013434

1055751654 发表于 2020-3-8 19:44

在报表中将一个3月改为9月后，运行不会新建对应的9月工作表
我的那个代码问题出在哪里您知道吗？

hermit013434

各位大神，有没有简短点的
另外，我想知道我的那段代码问题出在哪里？

1055751654

hermit013434 发表于 2020-3-8 20:33
在报表中将一个3月改为9月后，运行不会新建对应的9月工作表
我的那个代码问题出在哪里您知道吗？

试了可以呀

1055751654

hermit013434 发表于 2020-3-8 20:35
各位大神，有没有简短点的
另外，我想知道我的那段代码问题出在哪里？

改一下，

1. Option Explicit
   
2. Sub 玩玩()
   
3. Dim d As Object
   
4. Dim arr, q As Integer
   
5. Dim rng, sh As Worksheet
   
6. Dim w%, e%, r&, i
   
7. On Error Resume Next
   
8. Application.DisplayAlerts = False
   
9. Set d = CreateObject("scripting.dictionary")
   
10.     For Each sh In Worksheets
    
11.     If sh.Name <> "报表" And sh.Name <> "源数据" Then
    
12.     sh.Delete
    
13.     End If
    
14.     Next sh
    
15. With Worksheets("报表")
    
16. arr = .Range("a1").CurrentRegion
    
17.     For q = 2 To UBound(arr)
    
18.     d(arr(q, 5)) = ""
    
19.     Next q
    
20.     For Each rng In d.keys
    
21.     For w = 2 To UBound(arr)
    
22.         If .Cells(w, 5).Value = rng Then
    
23.         r = r + 1
    
24.         For e = 1 To UBound(arr, 2)
    
25.         arr(r, e) = .Cells(w, e).Value
    
26.         Next
    
27.     End If
    
28. Next
    
29. Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
    
30. sh.Name = rng
    
31. .Rows(1).Copy Worksheets(sh.Name).Range("a1")
    
32. Worksheets(sh.Name).[a2].Resize(r, UBound(arr, 2)) = arr
    
33. r = 0
    
34. Next rng
    
35. End With
    
36. Application.DisplayAlerts = True
    
37. End Sub
    

复制代码

hermit013434

1055751654 发表于 2020-3-8 21:02
改一下，

可以了，谢谢！刚开始学习vba,我好好消化下，一直没弄明白我那个代码问题出哪了

hermit013434

谢谢各位大神，问题已解决，我自己的那段代码问题也找到了，谢谢大家的帮助！