拆分成新工作表如何保持原有格式

乌云上空的流星

拆分成新的班级工作表后，没有按照原始工作的格式进行。在原始工作中，打印设置、字体、字号、单元格宽和高都发生改变了。

fzxba

以班级为单位拆分成新的工作表.zip (43.6 KB, 下载次数: 12)

2024-3-29 17:12 上传

点击文件名下载附件

补一个
是拆分成工作簿吧.rar (48.22 KB, 下载次数: 13)

2024-3-29 17:45 上传

点击文件名下载附件

feilanga

录制宏，粘贴

乌云上空的流星

fzxba 发表于 2024-3-29 17:12
补一个

非常感谢  祝您工作顺利

乌云上空的流星

feilanga 发表于 2024-3-29 17:19
录制宏，粘贴

谢谢您在百忙中抽出时间来帮助我

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()  '//2024.3.29
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("Sheet1")
   
9.     bt = 1
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then sht.Delete
    
12.     Next
    
13.     arr = sh.UsedRange
    
14.     For i = 3 To UBound(arr)
    
15.         s = arr(i, 1)
    
16.         If Not d.Exists(s) Then
    
17.             Set d(s) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         d(s)(i) = Application.Index(arr, i)
    
20.     Next i
    
21.     For Each k In d.keys
    
22.         sh.Copy after:=Sheets(Sheets.Count)
    
23.         Set sht = Sheets(Sheets.Count)
    
24.         m = d(k).Count
    
25.         With sht
    
26.             .Name = k
    
27.             .UsedRange.Offset(m + bt).Clear
    
28.             .DrawingObjects.Delete
    
29.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
30.         End With
    
31.     Next k
    
32.     sh.Activate
    
33.     Set d = Nothing
    
34.     Application.DisplayAlerts = True
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
37. End Sub
    

复制代码

乌云上空的流星

fzxba 发表于 2024-3-29 17:12
补一个

老师你好  您抽时间再看看  有点小问题  1、拆分后工作薄在排序上与总表不一致。2、从拆分时间上还能再优化一下吗？

乌云上空的流星

ykcbf1100 发表于 2024-3-29 19:16
参与一下。。。

谢谢您的帮助

baofa2

乌云上空的流星 发表于 2024-4-1 08:38
老师你好  您抽时间再看看  有点小问题  1、拆分后工作薄在排序上与总表不一致。2、从拆分时间上还能再优 ...

以班级为单位拆分成新的工作薄.zip (120.76 KB, 下载次数: 14)

2024-4-1 09:01 上传

点击文件名下载附件