拆分工作表至工作薄

----------------------------拆分成工作薄V1--SQL----格式没有保存--------
Sub 拆分工作薄()
    Application.ScreenUpdating = False '自动刷新为否
    Application.DisplayAlerts = False '过程中是否有对话模型为否
    Set d = CreateObject("scripting.dictionary")'创建字典
    ed = [a65536].End(xlUp).Row'统计共有多少行数据
    Set bt = [a1:N2]'标头部分
    ar = Range("A3:N" & ed)'数据区域
'把第三列中不重复的值插入字典
    For i = 1 To ed - 2
        d(ar(i, 3) & "") = 0
    Next i
'设置数据库的连接
    Set cn = CreateObject("adodb.connection")
    cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='Excel 8.0;hdr=Yes;IMEX=1';data source=" & ThisWorkbook.FullName
    k = d.Keys'关键列
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add'生成工作薄
        bt.Copy wb.Sheets(1).[a1]'在A1处把表头内容复制进去
        Sql = "select * from [连云港$a2:N65536] where 办事处 ='" & k(i) & "'"
        wb.Sheets(1).[a3].CopyFromRecordset cn.Execute(Sql)'把数据库中查出来的数据复制在A3处到新工作薄中
        wb.SaveAs ThisWorkbook.Path & "\" & k(i) & ".xls"'把新工作薄命名并存储到与打开表同目录下
        wb.Close 1
    Next i
    cn.Close
    Set cn = Nothing
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub


-----------------------拆分工作薄V2-------筛选-------格式还有------

Sub 筛选方式拆分为工作薄()
    Dim Rng As Range, wk As Workbook
    Application.ScreenUpdating = False
    Set Rng = Range("A1:N" & [A65536].End(xlUp).Row)
    ar = Range("A3:N" & [A65536].End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To [A65536].End(xlUp).Row - 2
        d(ar(i, 3) & "") = 0
    Next i
     cri = d.keys
   For i = 0 To d.Count - 1
        Range("C2").Select
        Selection.AutoFilter Field:=3, Criteria1:=cri(i)
       Set wk = Workbooks.Add
        Rng.SpecialCells(xlCellTypeVisible).Copy
        wk.ActiveSheet.Paste
        wk.SaveAs ThisWorkbook.Path & "\" & cri(i) & ".xls" , FileFormat _
        :=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False 
        wk.Close
    Next
    [C3].AutoFilter
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

----------------------筛选方式拆分成工作薄加保护--------


Sub 筛选方式拆分为工作薄()
    Dim Rng As Range, wk As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    Set Rng = Range("A1:N" & [A65536].End(xlUp).Row)
    ar = Range("A3:N" & [A65536].End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To [A65536].End(xlUp).Row - 2
        d(ar(i, 3) & "") = 0
    Next i
     cri = d.keys
   For i = 0 To d.Count - 1
        Range("C2").Select
        Selection.AutoFilter Field:=3, Criteria1:=cri(i)
       Set wk = Workbooks.Add
        Rng.SpecialCells(xlCellTypeVisible).Copy
        wk.ActiveSheet.Paste
        wk.SaveAs ThisWorkbook.Path & "\" & cri(i) & ".xls"
        With wk.ActiveSheet
        
            Cells.Select
            Cells.EntireColumn.AutoFit
            Cells.EntireRow.AutoFit
            Selection.Locked = False
            Selection.FormulaHidden = False
            Range("A2:F2").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Locked = True
            Selection.FormulaHidden = False
            .Protect Password:=5, DrawingObjects:=True, Contents:=True, Scenarios:= _
        True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingHyperlinks:=True, AllowSorting:= _
        True, AllowFiltering:=True, AllowUsingPivotTables:=True
        End With
        wk.Save
        wk.Close
    Next
    Application.ScreenUpdating = True
    MsgBox "处理完成"
End Sub

 

 

-------------------------------筛选方式拆分成工作薄加保护V2(筛选可正常使用)----------

 

Sub mywork()
    Dim Rng As Range, wk As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    Set Rng = Range("A1:J" & [A65536].End(xlUp).Row) '所有区域
    ar = Range("A3:J" & [A65536].End(xlUp).Row) '数据区域
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To [A65536].End(xlUp).Row - 2
        d(ar(i, 7) & "") = 0 '对于要分列的数据进行唯一性查询
    Next i
     cri = d.keys
   For i = 0 To d.Count - 1
        Range("G2").Select '对分列选中,选中G2单元格
        Selection.AutoFilter Field:=7, Criteria1:=cri(i) '对第七列筛选
       Set wk = Workbooks.Add
        Rng.SpecialCells(xlCellTypeVisible).Copy
        wk.ActiveSheet.Paste
        wk.SaveAs ThisWorkbook.Path & "\" & cri(i) & ".xls", FileFormat _
        :=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False '把筛选出来的表保存为XLS格式

        With wk.ActiveSheet
        
            Range("G2").Select
            Selection.AutoFilter '选中G2,筛选
            Cells.Select
            Cells.EntireColumn.AutoFit
            Cells.EntireRow.AutoFit
            Selection.Locked = False
            Selection.FormulaHidden = False
            Range("A2:F2").Select '选中要保护数据区域
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Locked = True
            Selection.FormulaHidden = False
            .Protect Password:=5, DrawingObjects:=True, Contents:=True, Scenarios:= _
        True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingHyperlinks:=True, AllowSorting:= _
        True, AllowFiltering:=True, AllowUsingPivotTables:=True
        End With
        wk.Save
        wk.Close
    Next
    Application.ScreenUpdating = True
    MsgBox "处理完成"
End Sub


 

 

同时也可以使用 彭希仁 老师写的EXCEL工具进行折分

http://club.excelhome.net/viewthread.php?tid=520111

http://club.excelhome.net/forum.php?mod=viewthread&tid=520111

 


 如果在EXCEL 2010 中拆分成2003格式的话，需要在  wk.SaveAs ThisWorkbook.Path & "\" & cri(i) & ".xls"  后加“ , FileFormat _
        :=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False ”