求大神相助，想要拆分表格时保留表头和原表格设置的格式

ykcbf1100

8楼代码再优化一下。。。

ykcbf1100

1. Sub ykcbf()     '//2025.12.17   原格式拆分成多工作簿
   
2.     ApplicationSettings False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     bt = 3       '//标题行号
   
6.     col = 3      '//拆分列号
   
7.     Dim tm: tm = Timer
   
8.     Set sh = ThisWorkbook.Sheets("汇总")
   
9.     fgf = Application.PathSeparator
   
10.     p = ThisWorkbook.Path & fgf
    
11.     p1 = p & "生成的新工作簿目录" & fgf
    
12.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
13.     With sh
    
14.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.         c = .Cells(bt, Columns.Count).End(xlToLeft).Column
    
16.         arr = .[a1].Resize(r, c).Value
    
17.     End With
    
18.     For i = bt + 1 To UBound(arr, 1)
    
19.         s = arr(i, col)
    
20.         If Len(s & "") > 0 Then
    
21.             If Not d.Exists(s) Then d(s) = s
    
22.         End If
    
23.     Next i
    
24.     For Each k In d.Keys
    
25.         sh.Copy: Set wb = ActiveWorkbook
    
26.         With wb.Sheets(1)
    
27.             .DrawingObjects.Delete
    
28.             .Name = CStr(k)
    
29.             .Rows(bt).AutoFilter col, "<>" & k
    
30.             .Rows(bt + 1 & ":" & r).Delete
    
31.             .AutoFilterMode = False
    
32.         End With
    
33.         wb.SaveAs p1 & k & ".xlsx", 51
    
34.         wb.Close False
    
35.     Next
    
36.     ApplicationSettings True
    
37.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & " 秒！" & vbCrLf & _
    
38.         "成功拆分成：" & d.Count & " 个工作簿。"
    
39.     ApplicationSettings True
    
40. End Sub
    
41. 
    
42. Private Sub ApplicationSettings(ByVal Reset As Boolean)
    
43.     With Application
    
44.         .ScreenUpdating = Reset: .DisplayAlerts = Reset
    
45.         .Calculation = IIf(Reset, xlCalculationAutomatic, xlCalculationManual)
    
46.         .AskToUpdateLinks = Reset: .EnableEvents = Reset: .EnableAnimations = Reset
    
47.     End With
    
48. End Sub
    

复制代码