如何工作表拆分成工作簿，新工作簿保留原有其他工作表

yynrzwh

拆分工作表成工作簿.rar (84.56 KB, 下载次数: 14)

2023-8-9 10:33 上传

点击文件名下载附件

糖↗小冷

limonet 发表于 2023-8-9 10:06
用到SAVECOPYAS等等

感谢老师的帮助，我研究一下，谢谢您

糖↗小冷

3190496160 发表于 2023-8-9 09:59

感谢老师拿出宝贵的时间，帮我写代码，非常感谢。

ykcbf1100

借题练习，多表只拆分一表

ykcbf1100

1. Sub ykcbf()    '//2025.11.24   总表拆分为多工作簿
   
2.     Dim tm As Double: tm = Timer
   
3.     Dim d As Object, p As String
   
4.     Dim ws As Workbook, sh As Worksheet
   
5.     Dim arr, bt As Long, col As Long
   
6.     Dim i As Long, s As String, k As Variant
   
7.     Dim wb As Workbook, rng As Range
   
8.     With Application
   
9.         .ScreenUpdating = False
   
10.         .DisplayAlerts = False
    
11.         .Calculation = xlCalculationManual
    
12.         .EnableEvents = False
    
13.     End With
    
14.     Set d = CreateObject("Scripting.Dictionary")
    
15.     p = ThisWorkbook.Path & Application.PathSeparator
    
16.     p1 = p & "拆分数据" & Application.PathSeparator
    
17.     Set ws = ThisWorkbook
    
18.     xm = "路线分段"    '//拆分表表名
    
19.     Set sh = ws.Sheets(xm)
    
20.     arr = sh.UsedRange.Value
    
21.     bt = 1: col = 3
    
22.     For i = bt + 1 To UBound(arr)
    
23.         s = Trim(arr(i, col))
    
24.         If s = "" Then Exit For
    
25.         If Not d.Exists(s) Then d.Add s, arr(i, 2)
    
26.     Next i
    
27.     For Each k In d.Keys
    
28.         ws.Sheets.Copy
    
29.         Set wb = ActiveWorkbook
    
30.         With wb.Sheets(xm)
    
31.             .Activate
    
32.             .Name = d(k)
    
33.             .DrawingObjects.Delete
    
34.             .Rows(bt).AutoFilter col, "<>" & k
    
35.             .UsedRange.Offset(bt).EntireRow.Delete
    
36.             .AutoFilterMode = False
    
37.         End With
    
38.         wb.SaveAs p1 & d(k) & ".xlsm", 52
    
39.         wb.Close False
    
40.     Next k
    
41.     With Application
    
42.         .DisplayAlerts = True
    
43.         .ScreenUpdating = True
    
44.         .Calculation = xlCalculationAutomatic
    
45.         .EnableEvents = True
    
46.     End With
    
47.     MsgBox "拆分完成！共用时：" & Format(Timer - tm, "0.000") & " 秒" & vbCrLf & _
    
48.         "共生成 " & d.Count & " 个工作簿。", vbInformation
    
49. End Sub
    
50. 
    

复制代码

yellowhawk

借题练习一下：
Sub SplitWorkbookByLineName()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("路线分段")
   
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
   
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
   
    Dim i As Long
    For i = 2 To lastRow
        Dim lineCode As String
        lineCode = ws.Cells(i, "B").Value
        
        If Not dict.Exists(lineCode) Then
            dict.Add lineCode, New Collection
        End If
        dict(lineCode).Add i
    Next i
   
    Dim key As Variant
    For Each key In dict.Keys
        Dim newWb As Workbook
        Set newWb = Workbooks.Add
        
        ' 复制所有工作表到新工作簿
        Dim sheet As Worksheet
        For Each sheet In ThisWorkbook.Worksheets
            sheet.Copy After:=newWb.Sheets(newWb.Sheets.Count)
        Next sheet
        
        ' 删除不需要的数据行（除了标题行）
        Dim j As Long
        For j = lastRow To 2 Step -1
            If ws.Cells(j, "B").Value <> key Then
                newWb.Sheets("路线分段").Rows(j).Delete
            End If
        Next j
        
        ' 保存新工作簿
        newWb.SaveAs Filename:=ThisWorkbook.Path & "\" & key & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
        
        ' 关闭新工作簿
        newWb.Close SaveChanges:=False
    Next key
   
    MsgBox "拆分完成！"
End Sub