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

乌云上空的流星

保留此表的所有格式

hongshan2019

站内搜一下，有非常成熟的工具，随便拆

wowo000

楼主：附件（五十万行数据不卡）

乌云上空的流星

wowo000 发表于 2025-4-3 08:17
楼主：附件（五十万行数据不卡）

谢谢您在百忙中抽出时间来帮助我，运算速度超快。麻烦您再看一下，如何修改一下才能让行的高度、列的宽度以及页面设置都能与原始表一样。再次感谢您！

3190496160

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

这就要牺牲代码运行的速度，不过，只是拆分班级成绩表的话，数据量应该不会很大

3190496160

Sub 按班级拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
If Dir(lj & "拆分的工作簿", vbDirectory) = "" Then MkDir lj & "拆分的工作簿"
Set sht = ThisWorkbook.Sheets(1)
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r < 3 Or y < 4 Then MsgBox "成绩表工作表为空，请先导入数据！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
    mc = .[a1]
    For i = 3 To UBound(ar)
        If ar(i, 1) <> "" Then
            If Not d.exists(ar(i, 1)) Then
                Set d(ar(i, 1)) = .Rows(i)
            Else
                Set d(ar(i, 1)) = Union(d(ar(i, 1)), .Rows(i))
            End If
        End If
    Next i
End With
x = d.keys
For i = 0 To UBound(x)
    sht.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .UsedRange.Offset(2).Borders.LineStyle = 0
        .UsedRange.Offset(2) = Empty
        d.items()(i).Copy .[a3]
        .Name = x(i) & "班"
        For Each shp In .Shapes
            shp.Delete
        Next shp
    End With
    wb.SaveAs fileName:=ThisWorkbook.Path & "\拆分的工作簿\" & mc & x(i) & "班成绩统计表.xlsx"
    wb.Close
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "拆分完毕！", 64, "提醒！"
End Sub

3190496160

保留所有格式，包括页面设置拆分
以班级为单位拆分成新的工作表.rar (32.17 KB, 下载次数: 19)

2025-4-3 09:09 上传

点击文件名下载附件

lizhipei78

拆分不求人，保留原格式
https://club.excelhome.net/threa ... tml?_dsign=59ea1e22

ykcbf1100

参与一下，原格式拆分总表为多表

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

ykcbf1100

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

复制代码