一、功能概述

本VBA宏用于将Excel工作簿中的所有工作表批量拆分为独立的Excel文件，自动以每个工作表第一行的内容作为文件名，完整保留原有格式，仅去除公式，同时确保身份证号等长数字不发生精度丢失，拆分后的文件默认自动计算模式，打开无「手动重算」提示。

二、功能清单

三、完整VBA代码

以下为完整的VBA代码，可直接复制使用：

Option Explicit

Sub 拆分工作表_最终完整版()

DimwbSource As Workbook

Dimws As Worksheet

DimwbNew As Workbook

DimsavePath As String

DimfullFileName As String

DimnameRaw As String

DimshtName As String

DimfileName As String

Dimi As Integer

DimlastCol As Long

DimusedRng As Range

'======================可自定义参数 ======================

Constseparator As String = "_"' 第一行多单元格拼接分隔符

ConstskipHidden As Boolean = False' 是否跳过隐藏工作表：True=跳过，False=全部拆分

ConstfileExt As String = ".xlsx"' 保存文件后缀

'========================================================

SetwbSource = ThisWorkbook

savePath= wbSource.Path & "\"

'工作簿未保存则静默退出

IfwbSource.Path = "" Then GoTo CleanExit

'关闭界面刷新与警告，提升运行速度

Application.ScreenUpdating= False

Application.DisplayAlerts= False

Application.Calculation= xlCalculationManual

Application.EnableEvents= False

'遍历所有工作表

ForEach ws In wbSource.Worksheets

'按配置跳过隐藏工作表

IfskipHidden And ws.Visible <> xlSheetVisible Then GoTo NextSheet

'容错：获取已用区域，空白表直接跳过

OnError Resume Next

SetusedRng = ws.UsedRange

OnError GoTo 0

IfusedRng Is Nothing Then GoTo NextSheet

'单表独立错误捕获：单个表出错不影响其他表

OnError Resume Next

'1. 整表完整复制为新工作簿（100%保留所有格式）

ws.Copy

SetwbNew = ActiveWorkbook

IfNot wbNew Is Nothing Then

'2. 选择性粘贴去公式，保留文本格式（身份证号完整不变）

WithwbNew.Sheets(1).UsedRange

If.Cells.Count > 0 Then

.Copy

.PasteSpecialPaste:=xlPasteValuesAndNumberFormats

Application.CutCopyMode= False

EndIf

EndWith

'3. 提取第一行所有非空单元格内容，拼接生成名称

lastCol= ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

IflastCol > 0 Then

nameRaw= JoinFirstRow(ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol)), separator)

Else

nameRaw= ""

EndIf

'第一行全为空时，自动沿用原工作表名称

IfLen(Trim(nameRaw)) = 0 Then nameRaw = ws.Name

'4. 名称合规化处理

shtName= FixSheetName(nameRaw)

fileName= FixFileName(nameRaw) & fileExt

'5. 重名文件自动追加序号，避免覆盖

fullFileName= savePath & fileName

i= 1

DoWhile Dir(fullFileName) <> ""

fileName= FixFileName(nameRaw) & "(" & i & ")" & fileExt

fullFileName= savePath & fileName

i= i + 1

Ifi > 999 Then Exit Do ' 防止死循环

Loop

'6. 保存前恢复自动重算 → 确保新文件打开无"手动重算"提示

wbNew.Sheets(1).Name= shtName

Application.Calculation= xlCalculationAutomatic

wbNew.SaveAsFilename:=fullFileName, FileFormat:=xlOpenXMLWorkbook

Application.Calculation= xlCalculationManual ' 保存后切回手动，继续提速

wbNew.CloseSaveChanges:=False

SetwbNew = Nothing

EndIf

OnError GoTo 0

NextSheet:

Nextws

CleanExit:

'强制恢复Excel所有默认设置

Application.ScreenUpdating= True

Application.DisplayAlerts= True

Application.Calculation= xlCalculationAutomatic

Application.EnableEvents= True

End Sub

' 辅助函数：拼接第一行非空单元格文本，自动跳过错误值单元格

Function JoinFirstRow(rng As Range, sep As String) As String

Dimcell As Range

Dimres As String

res= ""

ForEach cell In rng

IfNot IsError(cell.Value) Then

IfTrim(cell.Text) <> "" Then

Ifres = "" Then

res= Trim(cell.Text)

Else

res= res & sep & Trim(cell.Text)

EndIf

EndIf

EndIf

Nextcell

JoinFirstRow= res

End Function

' 辅助函数：清理工作表名称（去非法字符+限制31字符，符合Excel规则）

Function FixSheetName(ByVal nameStr As String) As String

Diminvalid As Variant

Dimi As Integer

invalid= Array("\", "/", "?", "*", "[", "]", ":")

Fori = LBound(invalid) To UBound(invalid)

nameStr= Replace(nameStr, invalid(i), "")

Nexti

nameStr= Trim(nameStr)

IfLen(nameStr) > 31 Then nameStr = Left(nameStr, 31)

IfLen(nameStr) = 0 Then nameStr = "未命名"

FixSheetName= nameStr

End Function

' 辅助函数：清理文件名非法字符（符合Windows命名规则）

Function FixFileName(ByVal nameStr As String) As String

Diminvalid As Variant

Dimi As Integer

invalid= Array("\", "/", ":", "*", "?", "\"""", "<", ">", "|")

Fori = LBound(invalid) To UBound(invalid)

nameStr= Replace(nameStr, invalid(i), "")

Nexti

nameStr= Trim(nameStr)

IfLen(nameStr) = 0 Then nameStr = "未命名"

FixFileName= nameStr

End Function

四、使用步骤

1.打开需要拆分的 Excel 文件，先按 Ctrl+S 保存一次。

2.按 Alt + F11 打开 VBA 编辑器。

3.左侧右键点击你的工作簿 → 插入 → 模块。

4.将全部代码粘贴到右侧空白代码窗口中。

5.按 F5 运行「拆分工作表_最终完整版」即可。

五、参数说明

代码开头的参数可根据需要自行调整：

六、注意事项

•运行前建议先备份原文件，避免意外操作。

•必须先保存原 Excel 文件，否则程序无法获取保存路径。

•代码开头的 separator 可自行修改，调整第一行内容的拼接方式。

•如需跳过隐藏工作表，把 skipHidden 改为 True 即可。

•默认保存为 .xlsx 格式，如需其他格式可修改 fileExt 参数。