将1工作簿中多个工作表的数据按照列名拆分成多个工作簿

netwang99

需求：
1个excel工作簿中有多张表，每张表中涉及多个子公司数据，现在需要按照每个子公司名字创建一个新工作簿，其中只有该子公司自己的数据，也需要多张工作表
母表如下，我已经做了个vba，但是只能拆分1张工作表并且报错，求帮助完成：
拆分数据-test.zip (19.44 KB, 下载次数: 373)

2013-6-2 19:02 上传

点击文件名下载附件

需要生成子表格式如下：
公司1.zip (3.69 KB, 下载次数: 239)

2013-6-2 19:05 上传

点击文件名下载附件

zhaogang1960

请测试:

1. Sub 按钮1_Click()
   
2.     Dim cnn As New ADODB.Connection
   
3.     Dim SQL As String
   
4.     Dim mypath As String
   
5.     Dim strfile As String
   
6.     Dim i As Long
   
7.     Dim j As Long
   
8.     Dim m As Long
   
9.     Dim arr As Variant
   
10.     Dim k As String
    
11.     Dim t As String
    
12.     Dim d As New Dictionary
    
13.     For i = 1 To sheets.Count
    
14.         arr = sheets(i).Range("a1").CurrentRegion
    
15.         For j = 4 To UBound(arr, 2)
    
16.             d(arr(1, j)) = d(arr(1, j)) & "," & sheets(i).Name
    
17.         Next
    
18.     Next
    
19.     mypath = ThisWorkbook.Path & ""
    
20.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName
    
21.     For j = 0 To d.Count - 1
    
22.         k = d.Keys(j)
    
23.         t = d.Items(j)
    
24.         m = 0
    
25.         For i = 1 To sheets.Count
    
26.             If InStr(t, "," & sheets(i).Name) Then
    
27.                 m = m + 1
    
28.                 If m = 1 Then
    
29.                     strfile = mypath & k & ".xlsx"
    
30.                     If Dir(strfile) <> "" Then Kill strfile
    
31.                 End If
    
32.                 SQL = "select 项目,序号," & k & " into [" & strfile & "].[" & sheets(i).Name & "] from [" & sheets(i).Name & "$]"
    
33.                 cnn.Execute SQL
    
34.             End If
    
35.         Next
    
36.     Next
    
37.    
    
38.     MsgBox "拆分完毕。", vbInformation
    
39.     Set d = Nothing
    
40.     cnn.Close
    
41.     Set cnn = Nothing
    
42. End Sub
    

复制代码

zhaogang1960

请看附件
拆分数据-test.rar (18.46 KB, 下载次数: 745)

2013-6-2 19:56 上传

点击文件名下载附件

doitbest

1. Public Sub abc1()
   
2. Dim d As Object
   
3. Dim ar, i, ii, str, c, k, sht As Worksheet, wbk As Workbook, rng As Range, r
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set wbk = ThisWorkbook
   
7. For Each sht In Sheets
   
8.     ar = sht.Range("d1", sht.[iv1].End(1))
   
9.     For c = 1 To UBound(ar, 2)
   
10.         d(ar(1, c)) = d(ar(1, c)) & " " & sht.Name
    
11.     Next
    
12. Next
    
13. k = d.Keys
    
14. For i = 0 To UBound(k)
    
15.     Workbooks.Add
    
16.     str = Split(Trim(d(k(i))), " ")
    
17.     For ii = UBound(str) To 0 Step -1
    
18.         ActiveWorkbook.Sheets.Add(before:=ActiveWorkbook.Sheets(1)).Name = str(ii)
    
19.         r = wbk.Sheets(str(ii)).[a65536].End(3).Row
    
20.         c = wbk.Sheets(str(ii)).[1:1].Find(k(i), , , 1).Column
    
21.         Set rng = Union(wbk.Sheets(str(ii)).[a1].Resize(r, 2), wbk.Sheets(str(ii)).Cells(1, c).Resize(r))
    
22.         rng.Copy [a1]
    
23.     Next
    
24.     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & k(i) & ".xls", FileFormat:=xlNormal
    
25.     ActiveWorkbook.Close
    
26. Next
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

doitbest

请参考附件

netwang99

还没实验，先谢谢楼上两位大侠

liuyibull

领走学习，谢谢分享。

xinfl

这个非常有用，但和我平时的工作表列和行正好相反。也就是说我要拆分行的内容。5年来一直以手工拆分的，占用了大量时间，麻烦老师有空给帮助看看我的表怎么拆分，万分感谢。

魂断蓝桥

xinfl 发表于 2014-11-17 09:08
这个非常有用，但和我平时的工作表列和行正好相反。也就是说我要拆分行的内容。5年来一直以手工拆分的，占用 ...

Sub cf()
Dim cnn As Object, rs As Object, SQL$, sFile$, i&, J&
Dim msg As VbMsgBoxResult
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
msg = MsgBox("删除此目录下除总表外所有文件", vbYesNo)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If msg = vbNo Then Exit Sub
On Error Resume Next
Kill ThisWorkbook.Path & "\" & "*.*"
On Error GoTo 0
cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=yes'; Data Source=" & ThisWorkbook.FullName
For J = 1 To 3
    SQL = "select distinct 公司  from [" & Sheets(J).Name & "$a1:M] where 公司 is not null"
    rs.Open SQL, cnn, 1, 1
        For i = 1 To rs.RecordCount
            sFile = ThisWorkbook.Path & "\" & rs.Fields(0).Value & ".xls"
            SQL = "select * into [" & sFile & "].[" & Sheets(J).Name & "] from [" & Sheets(J).Name & "$] where 公司='" & rs.Fields(0).Value & "'"
            cnn.Execute SQL
            rs.MoveNext
        Next
    rs.Close
Next
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

mingch

魂断蓝桥 发表于 2014-11-17 10:55
Sub cf()
Dim cnn As Object, rs As Object, SQL$, sFile$, i&, J&
Dim msg As VbMsgBoxResult

太有用了，这个代码。真的可以实现！但是如果能够修改为可以自由选择按哪一列为条件来拆分，如公司、车型或类别等来拆分，并且如果表格的标题不为1行，也可以自由指定标题行数，那样就更加完美了。期待增加，以使功能更强大，非常感谢。

补充内容 (2014-12-30 09:40):
请教——魂断蓝桥：能否将此代码修改成更具个性化的需求呢？如上所描述，非常感谢