拆分到新工作簿里

ykcbf1100

武松打鼓 发表于 2025-12-16 11:13
要把拆分的表保存在一个新工作簿里，不要在原工作簿里。

改好了。。。

ykcbf1100

1. Sub ykcbf()   '2025.12.16
   
2.     ApplicationSettings False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path & Application.PathSeparator
   
5.     With Application.FileDialog(msoFileDialogFilePicker)
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         .Title = "请选择对应Excel文件"
   
8.         .AllowMultiSelect = False
   
9.         .Filters.Clear
   
10.         .Filters.Add "Excel文件", "*.xls*"
    
11.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
12.     End With
    
13.     bt = Val(Application.InputBox("请输入标题行数：默认是1行", "标题行数", 1))
    
14.     col = Val(Application.InputBox("请输入拆分列列号：默认是8列", "拆分依据列列号", 8))
    
15.     If col = 0 Or bt = 0 Then Exit Sub
    
16.     tm = Timer
    
17.     Set wb = Workbooks.Open(f, 0)
    
18.     wb.Sheets(1).Copy
    
19.     Set wb1 = ActiveWorkbook
    
20.     Set sh = wb1.Sheets(1)
    
21.     wb.Close False
    
22.     With sh
    
23.         r = .Cells(.Rows.Count, col).End(xlUp).Row
    
24.         c = .Cells(bt, Columns.Count).End(xlToLeft).Column
    
25.         arr = .[A1].Resize(r, c).Value
    
26.     End With
    
27.     For i = bt + 1 To UBound(arr, 1)
    
28.         If Len(arr(i, col) & "") > 0 Then
    
29.             s = arr(i, col)
    
30.             If Not d.Exists(s) Then d(s) = True
    
31.         End If
    
32.     Next i
    
33.     For Each k In d.Keys
    
34.         sh.Copy After:=wb1.Sheets(wb1.Sheets.Count)
    
35.         With wb1.Sheets(wb1.Sheets.Count)
    
36.             .DrawingObjects.Delete
    
37.             .Name = CStr(k)
    
38.             .Rows(bt).AutoFilter col, "<>" & k
    
39.             .Rows(bt + 1 & ":" & r).Delete
    
40.             .AutoFilterMode = False
    
41.         End With
    
42.     Next
    
43.     sh.Activate
    
44.     wb1.SaveAs p & "工作簿另存.xlsx", 51
    
45.     wb1.Close False
    
46.     ApplicationSettings True
    
47.     If d.Count > 0 Then
    
48.         MsgBox "■ 拆分操作完成 ■" & vbCrLf & _
    
49.             "═══════════════════════" & vbCrLf & _
    
50.             "■ 处理时间: " & Format(Timer - tm, "0.000") & "秒" & vbCrLf & _
    
51.             "■ 处理行数: " & UBound(arr) - bt & "行" & vbCrLf & _
    
52.             "■ 生成表数: " & d.Count & "个" & vbCrLf & _
    
53.             "═══════════════════════", vbInformation, "执行报告"
    
54.     End If
    
55. End Sub
    
56. 
    
57. Private Sub ApplicationSettings(ByVal Reset As Boolean)
    
58.     With Application
    
59.         .ScreenUpdating = Reset
    
60.         .DisplayAlerts = Reset
    
61.         .Calculation = IIf(Reset, xlCalculationAutomatic, xlCalculationManual)
    
62.         .AskToUpdateLinks = Reset
    
63.         .EnableEvents = Reset
    
64.     End With
    
65. End Sub
    

复制代码

武松打鼓

liulang0808 发表于 2025-12-16 11:24
原来代码基础上调整了，看看是否可行

希望拆分成的新表都在一个工作簿里-1簿多表而不是1簿1表

liulang0808

。。。。。。。。。。。。

武松打鼓

liulang0808 发表于 2025-12-16 16:01
。。。。。。。。。。。。

运行后在弹出的窗口里，如果不输内容点击取消，出现弹窗错误，怎么解决

liulang0808

武松打鼓 发表于 2025-12-17 08:51
运行后在弹出的窗口里，如果不输内容点击取消，出现弹窗错误，怎么解决

这个是楼主源代码就有的功能，不选择，按照哪一列拆分呢？
现在改了，不选择，退出程序。

sungtinedue

    Sub 导出文件()
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Dim ws As Worksheet, nw As Workbook, wb As Workbook
        Dim savePath As String
        
        ' 获取当前工作簿路径
        savePath = ThisWorkbook.Path & "\"
        
        Set wb = ThisWorkbook
        ' 创建新工作簿
        Set nw = Workbooks.Add(xlWBATWorksheet)
        For Each sht In wb.Sheets
            If sht.Name <> "数据源" Then
                sht.Move after:=nw.Sheets(nw.Sheets.Count)
            End If
        Next
        ' 删除新工作簿中自动生成的空白工作表
        nw.Sheets("Sheet1").Delete
        
        ' 保存新文件并关闭
        nw.SaveAs Filename:=savePath & "拆分表" & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        nw.Close SaveChanges:=False
        
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        MsgBox "导出成功！"
        
    End Sub