使用vba将汇总表拆分

阿里九九他小弟

我是刚刚学习使用VBA的，我想把“汇总表”按班级拆分成独立的sheet，我的思路是先建以班级名称命名的sheet，再往相应的sheet中填内容，但是在建sheet的过程中会多出来好多未命名的sheet，不知为什么

Sub xinjiansheet()      '==================以C列的单元格内容新建
Dim d As Integer, sht As Worksheet
d = 3
Set sht = Worksheets("汇总表")
Do While sht.Cells(d, "C") <> ""
On Error Resume Next
    If Worksheets(sht.Cells(d, "C")) Is Nothing Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sht.Cells(d, "C").Value
    End If
    d = d + 1
Loop
End Sub
想请教一下我的问题出在什么地方了

windimi007

因为出错的同时工作表已经新建了，按你的思路大致改了下：

1. Sub xinjiansheet()      '==================以I列的单元格内容新建sheet
   
2. Dim d As Integer, sht As Worksheet
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. d = 3
   
6. Set sht = Worksheets("汇总表")
   
7. Do While sht.Cells(d, "C") <> ""
   
8. On Error Resume Next
   
9.     If Worksheets(sht.Cells(d, "C")) Is Nothing Then
   
10.         Worksheets.Add after:=Worksheets(Worksheets.Count)
    
11.         ActiveSheet.Name = sht.Cells(d, "C").Value
    
12.         If Err.Number = 1004 Then ActiveSheet.Delete
    
13.     End If
    
14.     d = d + 1
    
15. Loop
    
16. Application.DisplayAlerts = True
    
17. Application.ScreenUpdating = True
    
18. End Sub

复制代码

liulang0808

你这个是循环创建新表的，
那个Do While loop，你好好看看条件的，

chxw68

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   Dim ws As Worksheet
   
7.   Dim rng As Range
   
8.   Application.DisplayAlerts = False
   
9.   Application.ScreenUpdating = False
   
10.   
    
11.   mybook = ThisWorkbook.FullName
    
12.   
    
13.   For Each ws In Worksheets
    
14.     If ws.Name <> "汇总表" Then
    
15.       ws.Delete
    
16.     End If
    
17.   Next
    
18.   Set rng = Worksheets("汇总表").Rows("1:2")
    
19.   
    
20.   With cnn
    
21.     .Provider = "microsoft.jet.oledb.4.0"
    
22.     .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
23.     .Open
    
24.   End With
    
25.   sql = "select distinct 班级 from [汇总表$a2:h] where not isnull(班级)"
    
26.   arr = Application.Transpose(Application.Transpose(cnn.Execute(sql).GetRows()))
    
27.   For i = 1 To UBound(arr)
    
28.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
29.     sql = "select * from [汇总表$a2:h] where 班级='" & arr(i) & "'"
    
30.     rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
31.     With ws
    
32.       .Name = arr(i)
    
33.       rng.Copy .Range("a1")
    
34.       .Range("a3").CopyFromRecordset rs
    
35.       r = .Cells(.Rows.Count).End(xlUp).Row
    
36.       .Range("a2:h" & r).Borders.LineStyle = xlContinuous
    
37.     End With
    
38.     rs.Close
    
39.   Next
    
40.   cnn.Close
    
41.   Set cnn = Nothing
    
42.   Application.DisplayAlerts = True
    
43.   Application.ScreenUpdating = True
    
44. End Sub

复制代码

lhdcxz

Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Index <> 1 Then
      sht.Delete
    End If
Next
    Set d = CreateObject("scripting.dictionary") '后期绑定
    r = [c65536].End(3).Row '最大行数
    arr = Range("a3:h" & r) '数据区域放数组
    For i = 1 To UBound(arr) '数组维可用的最大下标循环
        bm = arr(i, 3) '关键字
        If Not d.Exists(bm) Then '判断关键词在字典里不存在
            Set d(bm) = Union(Rows("1:2"), Rows(i + 2)) '新关键字形成字典并且连接表头和对应行作为条目值
        Else
            Set d(bm) = Union(d(bm), Rows(i + 2)) '在已经有的字典连接已有条目和对应行作为条目值
        End If
    Next
    dk = d.Keys '关键字放数组
    dt = d.Items '条目放数组
    For i = 0 To UBound(dk) '对关键字个数循环
        Sheets.Add after:=Sheets(Sheets.Count) '添加工作表
        ActiveSheet.Name = dk(i) '
        dt(i).Copy ActiveSheet.[a1] '条目拷贝到工作表
    Next
Application.DisplayAlerts = True
End Sub

chxw68

刚做完这样一道题，修改后顺便发了上来，供参考。从提取班级名称到生成班级表格都是用ADO+SQL完成，一气呵成，比较简练。

LMY123

ADO及字典拆分工作表