运行 VBA 宏时 Excel 崩溃

Question

我有一个带有 VBA 宏的工作簿，我每天都会在其中粘贴大量数据并对其进行格式化，使用针对隐藏工作表的 vlookup 填充额外字段，将数据拆分为单独的工作表，并将每个工作表另存为CSV 文件。

这个过程在一周 7 天中有 6 天完美运行，只有在我运行周日数据时才会出现问题。 工作簿中的所有 VBA 宏都可以正常工作，直到我进入保存 CSV 的步骤，然后强制关闭 Excel 工作簿。 我注意到它保存了 1 个工作表（名为 RCM），但即使它不正确，因为它只将第一行拉到文件中，并且该行来自不正确的工作表。

我认为问题出在工作表名称上（因为我有一个名为 RCM1 的隐藏工作表，并且隐藏的工作表没有保存）。但是我尝试重命名工作表并且仍然遇到同样的问题。 我现在不确定是什么导致 Excel 仅在使用这些特定数据时崩溃。

这是宏的保存部分

Sub SaveSheets()
'
' SaveSheets Macro
' Saves sheets as individual CSV files
'

'

Dim csvPath As String
Dim DateName As String
csvPath = "C:\Daily Batch Files"
r = Worksheets("Data").Range("B2")
DateName = "batchredeem.001." & WorksheetFunction.Text(r, "mmmmdd") & "_"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Work").ShowAllData
For Each xWs In ThisWorkbook.Sheets
If xWs.Visible = xlSheetVisible And xWs.Name <> "Magic Buttons" And xWs.Name <> "Data" And xWs.Name <> "Work" Then
            xWs.Copy
            Application.ActiveWorkbook.SaveAs Filename:=csvPath & "\" & DateName & xWs.Name & ".csv", FileFormat:=xlCSV
            Application.ActiveWorkbook.Close False
        ElseIf xWs.Name = "Work" Then
            xWs.Copy
            Application.ActiveWorkbook.SaveAs Filename:=csvPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV
            Application.ActiveWorkbook.Close False
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

**编辑以添加其他信息： 如果我在运行宏之前更改工作表的名称，它根本不会保存重命名的“RCM”工作表 - 但是它适用于前一个工作表，如果我删除“RCM”工作表，整个宏运行正常。

***EDIT 2 - 我也不能手动“复制”“RCM”工作表，但我可以手动复制任何其他工作表。另外，如果我保存整个工作簿，然后运行宏，它可以正常工作！我很困惑，不知道为什么它不适用于这张工作表。

Answer 1

将工作表导出为一个工作表文件

Option Explicit

Sub ExportVisibleWorksheets()
' Saves worksheets as individual CSV files

    ' Source
    Const sExceptionsList As String = "Magic Buttons,Work,Data"
    Const sSpecialName As String = "Work" ' exported differently
    ' Source Lookup
    Const slName As String = "Data" ' included in the exceptions list
    Const slCellAddress As String = "B2"
    ' Destination
    Const dDateLeft As String = "batchredeem.001."
    Const dDateMidFormat As String = "mmmmdd"
    Const dDateRight As String = "_"
    Dim dFolderPath As String: dFolderPath = "C:\Daily Batch Files\"
    ' The following two depend on each other!
    Dim dFileExtension As String: dFileExtension = ".csv"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlCSV
    
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' doesn't exist
    
    If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = swb.Worksheets(slName)
    Dim sCell As Range: Set sCell = sws.Range(slCellAddress)
    
    Dim sExceptions() As String: sExceptions = Split(sExceptionsList, ",")
    Dim dDateMid As String
    dDateMid = WorksheetFunction.Text(sCell.Value, dDateMidFormat) ' English
    'dDateMid = Format(sCell.Value, dDateMidFormat) ' International
    Dim dDateName As String: dDateName = dDateLeft & dDateMid & dDateRight
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim dFilePath As String
    Dim dwsCount As Long
    Dim ErrNum As Long
    Dim DoNotCopy As Boolean
    
    For Each sws In swb.Worksheets
        
        If sws.Visible = xlSheetVisible Then
            
            If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
                dFilePath = dFolderPath & dDateName & sws.Name & dFileExtension
            ElseIf StrComp(sws.Name, sSpecialName, vbTextCompare) = 0 Then
                dFilePath = dFolderPath & sws.Name & dFileExtension
                If sws.AutoFilterMode Then
                    sws.ShowAllData
                End If
            Else
                DoNotCopy = True
            End If
            
            If DoNotCopy Then
                DoNotCopy = False
            Else
                sws.Copy
                Set dwb = Workbooks(Workbooks.Count)
                Application.DisplayAlerts = False ' overwrite: no confirmation
                On Error Resume Next ' prevent error if file is open
                    dwb.SaveAs Filename:=dFilePath, FileFormat:=dFileFormat
                    ErrNum = Err.Number
                On Error GoTo 0
                Application.DisplayAlerts = True
                dwb.Close SaveChanges:=False
                If ErrNum = 0 Then
                    dwsCount = dwsCount + 1
                Else
                    ErrNum = 0
                End If
            End If
        
        End If
    
    Next
    
    Application.ScreenUpdating = True

    Select Case dwsCount
        Case 0: MsgBox "No worksheets exported.", vbExclamation
        Case 1: MsgBox "One visible worksheet exported.", vbInformation
        Case Else
            MsgBox dwsCount & " visible worksheets exported.", vbInformation
    End Select

End Sub