VBA拆分工作簿示例

Sub test()
 Dim rng As Range, wbDest As Workbook, wsDest As Worksheet, wsCbasis As Worksheet
 Dim DTCCstr As Variant, var As Variant, DTCCcol As New Collection, x As Long
 
 With Application
   .EnableAnimations = False
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
 End With
 
 Set wsCbasis = Sheets("源数据")
 With wsCbasis
   var = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
 
   For x = 0 To UBound(var)
     On Error Resume Next
     DTCCcol.Add var(x, 1), CStr(var(x, 1))
     On Error GoTo 0
   Next x
 
   If Not .AutoFilterMode Then .Range("A1").AutoFilter
   Set rng = .UsedRange
 
   For Each DTCCstr In DTCCcol
     rng.AutoFilter 2, DTCCstr
     rng.SpecialCells(12).Copy
     Set wbDest = Workbooks.Add
     Set wsDest = wbDest.Sheets(1)
     With wsDest.Range("A1")
       .PasteSpecial 8
       .PasteSpecial 12
       .PasteSpecial -4122
     End With
     Application.CutCopyMode = False
     wbDest.SaveAs ThisWorkbook.Path & "/" & DTCCstr & ".xlsx"
     wbDest.Close
   Next DTCCstr
   rng.AutoFilter
 End With
 
 With Application
   .EnableAnimations = True
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
 End With
End Sub