VBA脚本导出指定工作表至CSV触发运行时错误1004求助

原代码核心问题 #

• 变量i未初始化且未递增：i默认值为0，循环中未自增，导致每次都访问数组第一个元素，与遍历的工作表不匹配触发错误
• 循环逻辑错位：遍历所有工作表，但判断的是数组中指定工作表的可见性，逻辑完全不对应
• 界面更新未恢复：代码末尾未将Application.ScreenUpdating恢复为True，会导致Excel界面无法正常刷新
• 变量命名冲突：wbNew同时指代原工作簿和新建工作簿，造成逻辑混乱
• 缺失工作表存在性检查：未验证数组中的工作表名是否真实存在，拼写错误会直接触发1004错误
• 数组元素含多余空格：原Split后的部分工作表名前有空格，导致无法匹配真实工作表

修正后的完整代码 #

Private Sub ExportSheets()
    Dim ws As Worksheet
    Dim wbTemp As Workbook ' 重命名避免变量冲突
    Dim myWorksheets() As String
    Dim sFolderPath As String
    Dim FileName1 As String
    Dim i As Integer
    Dim wsName As String
    
    ' 获取文件名和目标文件夹路径
    FileName1 = ThisWorkbook.Range("PMC_Name").Value
    sFolderPath = ThisWorkbook.Path & "\" & FileName1 & " - Import Templates"
    
    ' 初始化工作表数组，修正原数组中的空格问题
    myWorksheets = Split("Chart of Accounts,Custom Mapping File,Custom Chart of Accounts,Conventional Default COA,Conventional Mapping File,CONV Chart of Accounts,HUD Chart of Accounts,Affordable Default COA,Affordable Mapping File,Entities,Properties,Floors,Units,Area Measurement,Tenants,Account Labels,Leases,Scheduled Charges,Tenant Beginning Balances,Vendors,Vendor Beginning Balances,Customers,Customer Beginning Balances,GL Beginning Balances,GL Detail,Bank Accounts,Budgets,Budgeting COA,Budgeting Conventional COA,Budgeting Affordable COA,Budgeting Job Positions,Budgeting Employee List,Budgeting Workers Comp,Expense Pools,Lease Recoveries,Index Code,Lease Sales,Option Types,Clause Types,Lease Clauses,Lease Options,Budgeting Current Budget Import,Job Cost,Draw Model Detail,Job Cost History,Job Cost Budgets,Fixed Assets,Condo Properties,Owners,Ownership Information,Ownership Billing,Owner Charges", ",")
    
    ' 用FileSystemObject可靠判断文件夹是否存在
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(sFolderPath) Then
            MsgBox "目标文件夹已存在，请重命名或删除后重试。", vbCritical, "错误"
            Exit Sub
        End If
        .CreateFolder sFolderPath
    End With
    
    ' 关闭界面刷新和保存提示，提升效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 遍历指定的工作表数组
    For i = LBound(myWorksheets) To UBound(myWorksheets)
        wsName = Trim(myWorksheets(i)) ' 去除元素两端可能的空格
        
        ' 检查工作表是否存在
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(wsName)
        On Error GoTo 0
        
        If Not ws Is Nothing Then
            ' 仅导出可见工作表
            If ws.Visible = xlSheetVisible Then
                Debug.Print "正在导出: " & ws.Name
                ws.Copy ' 创建包含当前工作表的新工作簿
                Set wbTemp = ActiveWorkbook
                ' 保存为CSV格式（23对应xlCSVWindows）
                wbTemp.SaveAs sFolderPath & "\" & ws.Name & ".csv", FileFormat:=23
                wbTemp.Close SaveChanges:=False
                Set wbTemp = Nothing
            End If
            Set ws = Nothing
        Else
            Debug.Print "未找到指定工作表: " & wsName
        End If
    Next i
    
    ' 恢复Excel默认设置
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "工作表导出完成，文件路径：" & vbNewLine & vbNewLine & sFolderPath, vbExclamation, "导出完成"
End Sub

修正关键点说明 #

1. 改为遍历指定工作表数组，确保只处理目标工作表
2. 初始化并递增循环变量i，正确访问数组每个元素
3. 增加工作表存在性检查，避免因拼写错误触发错误
4. 修正数组元素的空格问题，确保能匹配真实工作表名
5. 恢复界面更新设置，避免Excel界面异常
6. 添加DisplayAlerts关闭保存提示，提升导出效率

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