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

没头脑和不高兴7

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


之前按照大神的方法已经可以实现一个总表按照部门拆分成独立的表格，但是还需要保留表头和原数据的所在的单元格格式，保留颜色和框线，需要怎么修改代码？？

可否有大神相助实现该想法~~~



代码如下：

Sub Opiona()
    Rem 禁止系统刷屏?触发其他事件等
    'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    Application.StatusBar = True   '关闭系统状态条
    Dim T
    T = Timer   '//开始时间

    Dim SQLARR
    Dim Str_coon, StrSQL As String
    Dim I, X, IROW, ICOL, FIRSTROW, LASTROW, LASTCOL, ICINT, INTX As Long
    Dim SH1, SH0, SHX, SHN, SHW, SH As Worksheet
    Dim ARX, BRX
    Dim FileArr, WB, FSO
    Dim StrWZ, StrBT, StrSH As String
    Dim PathG, PATHM As String

    Set SHX = Worksheets("汇总")
    PathG = ThisWorkbook.Path & "\拆分结果"  '//结果文件夹
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(PathG) = False Then
        MkDir PathG    '//创建文件夹
    End If


    Rem  模板中放置数据的单元格位置，和查询标题对应
    StrBT = ""
    For ICOL = 1 To SHX.Range("IT1").End(xlToLeft).Column
        If StrBT <> "" Then StrBT = StrBT & ","
        StrBT = StrBT & "[" & SHX.Cells(1, ICOL).Value & "]"
    Next

    Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
    Rem  先获取要拆分字段的不重复值
    StrSQL = "SELECT DISTINCT [部门]"
    StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
    StrSQL = StrSQL & " WHERE NOT [部门] IS NULL AND LEN([部门])>0"

    ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)  '//不重复姓名放入二维数组
    If ARX(0, 0) <> "" And ARX(0, 0) <> "Error" Then
        ICINT = UBound(ARX) + 1
        For X = 0 To ICINT - 1 '//循环每一个值

            Rem  提示信息，在状态栏显示
            Application.StatusBar = "需拆分总数：" & ICINT & " 个，当前是第：" & X + 1 & " 个，当前部门是：" & ARX(X, 0)
            DoEvents

            Rem 查询对应数据
            StrSQL = ""
            StrSQL = StrSQL & "SELECT " & StrBT
            StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
            StrSQL = StrSQL & " WHERE [部门]='" & ARX(X, 0) & "'"
            SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
            If SQLARR(0, 0) <> "" And SQLARR(0, 0) <> "Error" Then '//没有数据，在不保存
                Set WB = Workbooks.Add
                Set SHW = Worksheets(1)
                SHW.Name = "汇总"
                SHW.Range("A1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
                WB.SaveAs Filename:=PathG & "\" & ARX(X, 0) & ".XLS", FileFormat:=xlExcel8
                WB.Close True
            End If
        Next
    Else
        MsgBox "未发现拆分依据 需要的值！", vbInformation, "北极狐提示!!"
    End If

    Application.StatusBar = False   '恢复系统状态条
    Application.EnableEvents = True  '//  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
    MsgBox "一共用时：" & Format(Timer - T, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
End Sub

蓝桥玄霜

复制这个汇总表，删除表头下面的数据，重命名为“”模板“”
分表的代码：

没头脑和不高兴7

蓝桥玄霜 发表于 2019-8-8 14:38
复制这个汇总表，删除表头下面的数据，重命名为“”模板“”
分表的代码：

测试了，是可以拆分成带有原格式的数据表格，但是，不是独立的了，能否设置它是拆成独立表格并且带有格式的？

没头脑和不高兴7

顶一下，哪位大神、老师可以指导一下，我想要的是拆分成独立表格的同时保留原表的表头不变。

没头脑和不高兴7

还有一个，如果能设置拆分出来的表都在一个新建文件夹中，就更好了。

原先opiona大神的代码已经可以满足我拆分成为单个表格同时也体现在一个文件夹中，但是不能满足保留表头和单元格格式，可否有其他大神老师指导一下，非常感谢！！

学电子表格

搞的好复杂，没有那么复杂的 。

smsn

用高级筛选。录一段宏再改改

ykcbf1100

既然一直没解决，那我来试一下吧。

总表按部门拆分成原格式多工作簿，新生成工作簿另存在新文件夹中。

ykcbf1100

纯练手。。。

1. Sub ykcbf()     '//2024.5.3   原格式拆分成多工作簿
   
2.     Dim fso, sh, i, r
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     pt = 3       '//标题行号
   
8.     col = 3      '//拆分列号
   
9.     Set sh = ThisWorkbook.Sheets("汇总")
   
10.     p = ThisWorkbook.Path & ""
    
11.     p1 = p & "生成的新工作簿目录"
    
12.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
13.     arr = sh.UsedRange
    
14.     On Error Resume Next
    
15.     Dim tm: tm = Timer
    
16.     For i = pt + 1 To UBound(arr)
    
17.         s = arr(i, col)
    
18.         If Len(s) Then d(s) = ""
    
19.     Next i
    
20.     For Each k In d.keys
    
21.         sh.Copy
    
22.         Set wb = ActiveWorkbook
    
23.         With wb.Sheets(1)
    
24.             .Name = k
    
25.             .DrawingObjects.Delete
    
26.             .AutoFilterMode = False
    
27.             .Rows(pt).AutoFilter
    
28.             .Cells(3, col).AutoFilter Field:=col, Criteria1:="<>" & k
    
29.             .Range(.Cells(pt + 1, 1), .Cells(UBound(arr), 1)).EntireRow.Delete
    
30.             .AutoFilterMode = False
    
31.         End With
    
32.         wb.SaveAs p1 & k
    
33.         wb.Close
    
34.     Next
    
35.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒")
    
36.     Application.ScreenUpdating = True
    
37.     Application.DisplayAlerts = True
    
38. End Sub
    

复制代码