ExcelVBA拆分1.一簿多表_to_多簿一表

哆哆Excel

发布于 2023-09-09 10:52:04

2540

发布于 2023-09-09 10:52:04

文章被收录于专栏：哆哆Excel

ExcelVBA拆分1.一簿多表_to_多簿一表

拆分工作表：大概分为三类

=====start====

1.ExcelVBA拆分_一簿一表_to_多簿一表

2.ExcelVBA拆分之一簿一表_to_一簿多表

=====end====

【问题】

5如何把一个工作簿中的多个工作表拆分为一个工作表为一个文件，也就是：一簿多表_to_多簿一表

【思路】

循环每个工作表，把它另存为一个xlsx文件(代码按按钮依托的工作表不用拆分)

【使用方法视频演示】

横屏全屏观看效果更佳

【代码】

    '把当前表拆分：一簿一表_to_一簿多表
    '作者：哆哆
    '时间：2023-07
Sub yhd_ExcelVBA_1拆分_一簿多表_to_多簿一表()
    Dim save_path As String, ThisWb As Workbook, save_filename As String
    Dim ThisSht As Worksheet, eSht As Worksheet, k As Integer
    save_path = ThisWorkbook.Path & "\拆分\"
    If Dir(save_path, vbDirectory) = "" Then MkDir save_path
    Set ThisSht = ActiveSheet
    t = Timer()
    disAppSet (False)
    k = 0
    For Each eSht In Worksheets
        If eSht.Name <> ThisSht.Name Then
            save_filename = eSht.Name
            eSht.Copy
            ActiveWorkbook.SaveAs save_path & save_filename
            ActiveWorkbook.Close (True)
            k = k + 1
        End If
    Next
    disAppSet (True)
    MsgBox "完成，用时：" & Format(Timer - t, "0.00秒") & Chr(13) & k & "个工作簿，在【当前目录\拆分\】中"
    
End Sub
    '用法：disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
    With Application
        .ScreenUpdating = flag
        .DisplayAlerts = flag
        .AskToUpdateLinks = flag
        If flag Then
            .Calculation = xlCalculationAutomatic
        Else
            .Calculation = xlCalculationManual
        End If
    End With
End Sub

【效果】

看图

====图1====