将excle多个sheet页拆分成单独的工作簿

当excel中包含多个sheet页，需要将多个sheet页拆分成多个单独的excel，命名是sheet名称，可进行以下操作。

一、打开excle，选择任意一个sheet，右键->查看代码，如下图：

进入编辑页面

二、录入代码，该代码去除隐藏的sheet页

Sub SplitVisibleSheetsToFiles()
    '====================================================================
    ' 功能：将当前工作簿的可见Sheet保存为独立Excel文件
    ' 特点：
    ' 1. 自动跳过隐藏工作表（包括深度隐藏）
    ' 2. 自动处理文件名特殊字符
    ' 3. 支持自定义保存路径
    ' 4. 包含完整错误处理
    '====================================================================
    
    On Error GoTo ErrorHandler
    Dim startTime As Double
    startTime = Timer
    
    '---------------- 配置参数 -----------------
    Dim originalWB As Workbook
    Set originalWB = ThisWorkbook  ' 当前工作簿
    
    ' 选择保存路径
    Dim savePath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存位置"
        If .Show = -1 Then
            savePath = .SelectedItems(1) & "\"
        Else
            Exit Sub  ' 用户取消操作
        End If
    End With
    
    '---------------- 环境设置 -----------------
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    '---------------- 核心逻辑 -----------------
    Dim ws As Worksheet
    Dim newWB As Workbook
    Dim fileCounter As Integer
    fileCounter = 0
    
    ' 创建目标文件夹（如果不存在）
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath
    
    For Each ws In originalWB.Worksheets
        ' 跳过隐藏工作表（包括xlSheetHidden和xlSheetVeryHidden）
        If ws.Visible <> xlSheetVisible Then GoTo SkipSheet
        
        ' 显示处理进度
        Application.StatusBar = "处理进度: " & ws.Name & _
                                " (" & fileCounter + 1 & "/" & GetVisibleSheetCount(originalWB) & ")"
        
        ' 复制工作表到新工作簿
        ws.Copy
        Set newWB = ActiveWorkbook
        
        ' 删除其他工作表（如果有）
        DeleteExtraSheets newWB
        
        ' 生成安全文件名
        Dim safeFileName As String
        safeFileName = CleanFileName(ws.Name)
        Dim fullPath As String
        fullPath = savePath & safeFileName & ".xlsx"
        
        ' 处理文件名冲突
        fullPath = GenerateUniqueFileName(fullPath)
        
        ' 保存文件
        newWB.SaveAs Filename:=fullPath, FileFormat:=xlOpenXMLWorkbook
        newWB.Close SaveChanges:=False
        
        fileCounter = fileCounter + 1
        
SkipSheet:
    Next ws
    
    '---------------- 收尾工作 -----------------
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 完成提示
    MsgBox "成功拆分 " & fileCounter & " 个可见工作表" & vbCrLf & _
          "保存路径: " & savePath & vbCrLf & _
          "总耗时: " & Format(Timer - startTime, "0.00") & " 秒", _
          vbInformation, "操作完成"
    
    Exit Sub
    
ErrorHandler:
    MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & _
          "发生位置: " & ws.Name, vbCritical, "错误报告"
    ' 恢复系统设置
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

'════════════════════════════════════════
' 辅助函数
'════════════════════════════════════════
Function GetVisibleSheetCount(wb As Workbook) As Integer
    ' 统计可见工作表数量
    Dim ws As Worksheet
    Dim count As Integer
    count = 0
    For Each ws In wb.Worksheets
        If ws.Visible = xlSheetVisible Then count = count + 1
    Next
    GetVisibleSheetCount = count
End Function

Sub DeleteExtraSheets(wb As Workbook)
    ' 删除其他工作表
    Application.DisplayAlerts = False
    While wb.Worksheets.count > 1
        wb.Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
End Sub

Function CleanFileName(str As String) As String
    ' 清理非法字符
    Dim invalidChars As String
    invalidChars = "\/:*?""<>|"
    Dim i As Integer
    For i = 1 To Len(invalidChars)
        str = Replace(str, Mid(invalidChars, i, 1), "_")
    Next
    CleanFileName = Trim(str)
End Function

Function GenerateUniqueFileName(fullPath As String) As String
    ' 生成唯一文件名
    Dim counter As Integer
    counter = 1
    Dim originalName As String
    originalName = Left(fullPath, InStrRev(fullPath, ".") - 1)
    Dim ext As String
    ext = Mid(fullPath, InStrRev(fullPath, "."))
    
    While Len(Dir(fullPath)) > 0
        fullPath = originalName & "_" & Format(Now, "yymmdd") & "_" & counter & ext
        counter = counter + 1
    Wend
    GenerateUniqueFileName = fullPath
End Function

三、执行代码

选择运行->运行子程序或者直接F5运行代码

点击后选择对应的宏，点击运行

选择对应存放路径

选择路径后点击确定，弹出以下提示，选择“是”

弹出以下提示，表示拆分成功

在对应路径下进行查看，文件是否存在

本文章仅参考使用