Excel汇总表拆分

Sub 拆分当前工作簿()    Dim wb As Workbook    Dim sht As Worksheet    Dim prefix As String    Dim saveFolder As String    Dim newWb As Workbook    Dim i As Integer, fileCount As Integer    Dim answer As Integer    Dim userInput As String    ' 获取当前活动工作簿    Set wb = ActiveWorkbook    If wb Is Nothing Then MsgBox "未检测到打开的工作簿！": Exit Sub    ' 必须已保存    If wb.Path = "" Then        MsgBox "请先保存当前工作簿，再运行拆分！", vbExclamation        Exit Sub    End If    ' 默认前缀 = 工作簿名称（去掉扩展名）    prefix = Left(wb.Name, InStrRev(wb.Name, ".") - 1)    userInput = InputBox("请输入文件名前缀（前缀-工作表名.xlsx）", "设置前缀", prefix)    If StrPtr(userInput) = 0 Then Exit Sub    If userInput <> "" Then prefix = userInput    ' 默认保存路径 = 工作簿所在文件夹    saveFolder = wb.Path & Application.PathSeparator    ' 询问是否更改保存位置    answer = MsgBox("文件将保存到：" & vbCrLf & saveFolder & vbCrLf & _                    "是否更改保存位置？", vbYesNo + vbQuestion, "保存位置")    If answer = vbYes Then        userInput = Application.InputBox("请输入新的保存文件夹完整路径：" & vbCrLf & _                                         "（例如：C:\我的文件夹\ 或 /Users/用户名/Desktop/）", _                                         "更改保存位置", saveFolder)        If StrPtr(userInput) = 0 Then Exit Sub        If userInput <> "" Then            saveFolder = userInput            If Right(saveFolder, 1) <> Application.PathSeparator Then                saveFolder = saveFolder & Application.PathSeparator            End If        End If    End If    ' 确保文件夹存在    If Dir(saveFolder, vbDirectory) = "" Then        On Error Resume Next        MkDir saveFolder        If Err.Number <> 0 Then            MsgBox "无法创建文件夹：" & saveFolder & vbCrLf & "请检查路径是否正确。", vbExclamation            Exit Sub        End If        On Error GoTo 0    End If    ' 开始拆分    Application.ScreenUpdating = False    Application.DisplayAlerts = False    i = 0    For Each sht In wb.Sheets        ' 跳过隐藏工作表（可选：如需包含隐藏表，删除下面两行）        If sht.Visible <> xlSheetVisible Then GoTo NextSheet        i = i + 1        Application.StatusBar = "拆分中 (" & i & "/" & wb.Sheets.Count & ") " & sht.Name        sht.Copy        Set newWb = ActiveWorkbook        ' 清理工作表名中的非法字符        Dim cleanName As String        cleanName = sht.Name        cleanName = Replace(cleanName, "/", "、")        cleanName = Replace(cleanName, "\", "、")        cleanName = Replace(cleanName, ":", "：")        cleanName = Replace(cleanName, "*", "×")        cleanName = Replace(cleanName, "?", "？")        cleanName = Replace(cleanName, Chr(34), "''")        cleanName = Replace(cleanName, "<", "〈")        cleanName = Replace(cleanName, ">", "〉")        cleanName = Replace(cleanName, "|", "｜")        cleanName = Replace(cleanName, vbCr, "")        cleanName = Replace(cleanName, vbLf, "")        ' 处理重名文件：若文件已存在则添加序号        Dim fullPath As String        Dim version As Integer        version = 1        fullPath = saveFolder & prefix & "-" & cleanName & ".xlsx"        Do While Dir(fullPath) <> ""            fullPath = saveFolder & prefix & "-" & cleanName & "(" & version & ")" & ".xlsx"            version = version + 1        Loop        ' 保存文件        newWb.SaveAs fullPath, 51        newWb.Close False        Set newWb = NothingNextSheet:    Next sht    Application.ScreenUpdating = True    Application.DisplayAlerts = True    Application.StatusBar = False    ' 完成提示    answer = MsgBox("拆分完成！" & vbCrLf & "共生成 " & i & " 个文件" & vbCrLf & _                    "保存位置：" & saveFolder & vbCrLf & vbCrLf & _                    "是否打开该文件夹？", vbYesNo + vbInformation, "完成")    If answer = vbYes Then        On Error Resume Next        #If Mac Then            Shell "open " & saveFolder        #Else            Shell "explorer.exe " & saveFolder        #End If        On Error GoTo 0    End IfEnd Sub