一个工作簿多个SHEET根据某列字段拆分成多个工作簿多个SHEET

funsz

一个总表里有很多个SHEET，然后希望能拆分成，根据某个字段，然后还是保持原格式的表格，
附上表格样式，自己也尝试，但是功底有限，求教

总表拆分后各个小表.rar (97.02 KB, 下载次数: 265)

2015-8-10 10:59 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim ws As Worksheet
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   sm = Application.SheetsInNewWorkbook
   
10.   For Each ws In Worksheets
    
11.     With ws
    
12.       Set rng = Nothing
    
13.       Set rng = .UsedRange.Find(what:="理财中心", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)
    
14.       If Not rng Is Nothing Then
    
15.         r0 = rng.Row
    
16.         c0 = rng.Column
    
17.         r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
18.         c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    
19.         If r > r0 Then
    
20.           arr = .Cells(1, c0).Resize(r, 1)
    
21.           For i = r0 + 1 To UBound(arr)
    
22.             If Not d.exists(arr(i, 1)) Then
    
23.               Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
24.             End If
    
25.             If Not d(arr(i, 1)).exists(ws.Name) Then
    
26.               Set d(arr(i, 1))(ws.Name) = .Range("a1").Resize(r0, c)
    
27.             End If
    
28.             Set d(arr(i, 1))(ws.Name) = Union(d(arr(i, 1))(ws.Name), .Cells(i, 1).Resize(1, c))
    
29.           Next
    
30.         End If
    
31.       End If
    
32.     End With
    
33.   Next
    
34.   For Each aa In d.keys
    
35.     Application.SheetsInNewWorkbook = d(aa).Count
    
36.     Set wb = Workbooks.Add
    
37.     m = 0
    
38.     With wb
    
39.       For Each bb In d(aa).keys
    
40.         m = m + 1
    
41.         With .Worksheets(m)
    
42.           .Name = bb
    
43.           d(aa)(bb).Copy .Range("a1")
    
44.         End With
    
45.       Next
    
46.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa & ".xls"
    
47.       .Close False
    
48.     End With
    
49.   Next
    
50.   Application.SheetsInNewWorkbook = sm
    
51. End Sub
    

复制代码

chxw68

详见附件。

funsz

chxw68 发表于 2015-8-10 11:31
详见附件。

测试下，没问题，很好，继续研究学习，非常感谢

funsz

chxw68 发表于 2015-8-10 11:31
详见附件。

.SaveAs Filename:=ThisWorkbook.Path & "\" & aa & ".xls"
问下这句代码出错的原因有哪里，谢啦

funsz

chxw68 发表于 2015-8-10 11:31
详见附件。

我已经找到问题，谢啦，理财中心不能为空，为空就无法保存了

zax010

Sub zz()
    Dim d1 As New Dictionary, d2 As New Dictionary, sh As Worksheet, s As Range, ar
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Activate
        Set s = sh.UsedRange.Find("理财中心")
        If Not s Is Nothing Then
            ar = Range(s, Cells(s.End(xlDown).Row, s.Column))
            For i = 2 To UBound(ar)
                d1(ar(i, 1)) = ""
            Next
            d2(sh.Name) = Array(s.Row, s.Column)
        End If
    Next
    For Each k In d1.keys
        Sheets(d2.keys).Copy
        With ActiveWorkbook
            For Each sh In .Sheets
                lr = sh.[b65536].End(3).Row
                For i = lr To d2(sh.Name)(0) + 1 Step -1
                    If sh.Cells(i, d2(sh.Name)(1)) <> k Then sh.Rows(i).Delete
                Next
            Next
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            .Close True
        End With
    Next
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>>>>>

总表拆分后各个小表.rar (36.06 KB, 下载次数: 206)

2015-8-10 13:52 上传

点击文件名下载附件

funsz

zax010 发表于 2015-8-10 13:52
>>>>>>>>>>>>>>>>>>>>>>>>>

试试看，谢谢啦

ljh83818

zax010 发表于 2015-8-10 13:52
>>>>>>>>>>>>>>>>>>>>>>>>>

你好，你的拆分代码里面，如何把有些sheet我不需要拆分的，也复制到新sheet里面。