當我運行 VBA 宏時，Excel 崩潰

Question

我有一個帶有 VBA 宏的工作簿，我每天都在運行該宏，在其中粘貼大量數據並對其進行格式化，使用針對隱藏工作表的 vlookup 填充額外字段，將數據拆分為單獨的工作表，並將每個工作表另存為 CSV 文件.

這個過程在一周的 7 天中完美地運行了 6 天，並且只有在我運行周日數據時才會出現問題。 工作簿中的所有 VBA 宏都可以正常工作，直到我進入保存 CSV 的步驟，然后它強制關閉 excel 工作簿。 我注意到它保存了一個工作表（名為 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”表，整個宏運行正常。

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