数据按条件拆分成新表

hermit013434

3190496160 发表于 2020-3-8 17:05
你的代码整体思路欠佳，拆分问题，可以去看看这个帖子，下载就能用
Excel 灵活拆分工具-ExcelVBA程序开发- ...

感谢指正，刚开始学习，脑子有点涨，得好好消化

hermit013434

gxx75 发表于 2020-3-8 17:45
写 的 有 点 乱
Sub 水一个()
Dim arr, d, ar()

谢谢您的帮助！谢谢！

1055751654

原来楼主用的是筛选法，不错不错，学习了

一个小小蕉

Sub chaifenshuju()


Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l As Integer


l = InputBox("请输入你要按哪列分")


'删除无意义的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> "数据" Then
            sht1.Delete
        End If
    Next
End If
Application.DisplayAlerts = True '这个地方上课的时候我没改成true，请大家注意一下





irow = Sheet1.Range("a65536").End(xlUp).Row
'拆分表
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = Sheet1.Cells(i, l) Then
            k = 1
        End If
    Next
   
   
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
    End If

Next
'拷贝数据

For j = 2 To Sheets.Count
    Sheet1.Range("a1:f" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")
Next

Sheet1.Range("a1:f" & irow).AutoFilter

Sheet1.Select

MsgBox "已处理完毕"

End Sub




这个代码是挺通用的，不过你得保证报表那个sheet是sheet1，先把其它表删除

1055751654

hermit013434 发表于 2020-3-8 22:35
谢谢各位大神，问题已解决，我自己的那段代码问题也找到了，谢谢大家的帮助！

我也研究出来了

1. Option Explicit
   
2. Sub 拆分()
   
3. Dim d, y%, irow As Integer, rng
   
4. Set d = CreateObject("scripting.dictionary")
   
5. irow = Sheets("报表").Range("a65536").End(xlUp).Row
   
6.     For y = 2 To irow
   
7.     d(Cells(y, 5).Value) = ""
   
8.     Next y
   
9. For Each rng In d.keys
   
10.     Sheets.Add after:=Sheets(Sheets.Count)
    
11.     Sheets(Sheets.Count).Name = rng
    
12.     'Sheets("报表").Activate
    
13.     Sheets("报表").Range("a1:f" & irow).AutoFilter Field:=5, Criteria1:=rng
    
14.     Sheets("报表").Range("A1:f" & irow).Copy Sheets(rng).Range("a1")
    
15. Next
    
16. Sheets("报表").AutoFilterMode = False
    
17. End Sub
    

复制代码