以班级拆分成新工作表后保留原表所有格式（打印和行高列宽字体等）

quqiyuan

参与一下，仅供参考、、、

quqiyuan

代码如下。。。
Sub test1212()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    For Each sh In wb.Sheets
        If sh.Name <> sht.Name Then sh.Delete '删除其他工作表，请留意！！
    Next
    r = sht.Cells(Rows.Count, 1).End(3).Row
    c = sht.Cells(2, Columns.Count).End(1).Column
    Set Rng = sht.[a2].Resize(r - 1, c)
    Set d = CreateObject("scripting.dictionary")
    arr = Rng
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        If Not d.exists(s) Then
            d(s) = ""
        End If
    Next
    For Each Key In d.keys
        sht.AutoFilterMode = False
        Rng.AutoFilter Field:=1, Criteria1:=Key
        sht.Copy after:=wb.Sheets(wb.Sheets.Count)
        With ActiveSheet
            .Name = Key
            .DrawingObjects.Delete
            .Cells.ClearContents
            sht.UsedRange.SpecialCells(xlCellTypeVisible).Copy .[a1]
        End With
    Next
    Set d = Nothing
    sht.AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
End Sub

乌云上空的流星

3190496160 发表于 2025-4-3 09:09
保留所有格式，包括页面设置拆分

谢谢   正是我想的效果

ykcbf1100

乌云上空的流星 发表于 2025-4-3 08:45
谢谢您在百忙中抽出时间来帮助我，运算速度超快。麻烦您再看一下，如何修改一下才能让行的高度、列的宽度 ...

如果要保留原始表的行高、列宽以及页面设置，那拆分的速度肯定会明显下降的。不过，就附件这点数据，不管什么代码拆分，都是秒拆。

乌云上空的流星

quqiyuan 发表于 2025-4-3 09:32
参与一下，仅供参考、、、

谢谢您的帮助

乌云上空的流星

ykcbf1100 发表于 2025-4-3 09:31
参与一下，原格式拆分总表为多表

感谢您的帮助  祝生活愉快

ykcbf1100

乌云上空的流星 发表于 2025-4-3 13:34
感谢您的帮助  祝生活愉快

原代码拆分列有误，现已更新。

乌云上空的流星

ykcbf1100 发表于 2025-4-3 09:31
参与一下，原格式拆分总表为多表

更新一下，原拆分列有误。

老师  运行速度超快 生成的新工作表在同一工作簿下 我想要的结果是以每班生成一个新的工作簿  以便更快的单独发给每位班主任老师

ykcbf1100

乌云上空的流星 发表于 2025-4-3 14:35
老师  运行速度超快 生成的新工作表在同一工作簿下 我想要的结果是以每班生成一个新的工作簿  以便更快的 ...

被你标题误导，你那应该是拆分成多工作簿，你是表和簿不分的啊。
代码重写。

ykcbf1100

1. Sub ykcbf()   '//2025.4.3  总表拆分为工作簿
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set ws = ThisWorkbook
   
7.     Dim tm: tm = Timer
   
8.     On Error Resume Next
   
9.     Set sh = ws.ActiveSheet
   
10.     arr = sh.UsedRange
    
11.     bt = 2: col = 1
    
12.     For i = bt + 1 To UBound(arr)
    
13.         s = arr(i, col)
    
14.         If Len(s) = 0 Then Exit For
    
15.         d(s) = ""
    
16.     Next i
    
17.     For Each k In d.keys
    
18.         sh.Copy
    
19.         Set wb = ActiveWorkbook
    
20.         With wb.Sheets(1)
    
21.            .Name = k & "班"
    
22.             .DrawingObjects.Delete
    
23.             On Error Resume Next
    
24.             .AutoFilterMode = False ' 清除已有筛选
    
25.             On Error GoTo 0
    
26.             .Rows(bt).AutoFilter Field:=col, Criteria1:="<>" & k
    
27.             .UsedRange.Offset(bt).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    
28.             .AutoFilterMode = False
    
29.         End With
    
30.         wb.SaveAs p & k & "班"
    
31.         wb.Close
    
32.     Next
    
33.     Application.ScreenUpdating = True
    
34.     Application.DisplayAlerts = True
    
35.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
36. End Sub
    

复制代码