Excel VBA按行拆分导出xlsx文件出现多余工作表问题求解

问题排查结果 #

你代码的核心问题出在工作表创建逻辑上：你是在当前打开的原工作簿中新增工作表，执行保存操作时默认会导出整个原工作簿的所有工作表，因此最终文件会携带多余的原有工作表。同时未限定Range的所属工作表，也可能出现数据赋值错误。

修正后可运行代码 #

Sub split_file()
    Dim sourceWB As Workbook, newWB As Workbook
    Dim i As Long, exportPath As String
    ' 绑定原工作簿
    Set sourceWB = ThisWorkbook
    exportPath = "C:\test\"
    ' 提前判断导出文件夹是否存在，避免报错
    If Dir(exportPath, vbDirectory) = "" Then
        MkDir exportPath
    End If
    
    Application.ScreenUpdating = False ' 关闭屏幕更新提速
    For i = 2 To sourceWB.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
        ' 新建仅含1个工作表的空白工作簿
        Set newWB = Workbooks.Add(xlWBATWorksheet)
        ' 把对应行的Ax:Dx数据写入新工作簿的第一个工作表
        newWB.Sheets(1).Range("A1:D1").Value = sourceWB.Sheets("Sheet2").Range("A" & i & ":D" & i).Value
        ' 按要求命名保存并设密码
        newWB.SaveAs Filename:=exportPath & sourceWB.Sheets("Sheet2").Range("A" & i).Value & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, Password:="Welcome1"
        newWB.Close SaveChanges:=False
        Set newWB = Nothing ' 释放对象
    Next i
    Application.ScreenUpdating = True
    MsgBox "拆分完成！"
End Sub

注意事项 #

• 若你代码里的Sheet2是工作表的代码名称而非显示名称，可以把代码里的sourceWB.Sheets("Sheet2")换回Sheet2
• 若A列存在\/:*?"<>|这些Windows文件名禁止使用的字符，建议提前做字符替换处理，避免保存报错
• 代码已经新增了自动创建C:\test文件夹的逻辑，不需要提前手动创建

内容的提问来源于stack exchange，提问作者thangvc91