VBA代码复制工作簿内容并保存至指定文件夹时遇报错及性能问题

Let's walk through the problems in your code and fix both the save error and the slow runtime—here's what's going wrong and how to resolve it:

1. Why the Save Error Occurs #

• Missing valid filename: You’re trying to save as path2 & ".xlsx", which means the filename is just .xlsx—Windows doesn’t allow files without a proper name. You need to add a descriptive filename (e.g., "Pivot_Output.xlsx").
• Save path may not exist: If the \Tru\Sq\ subfolders don’t already exist in your source workbook’s directory, the SaveAs command will throw an error. We need to create the path first if it’s missing.
• Unqualified cell reference: In your row-deletion loop, Cells(i, 8).EntireRow.Delete doesn’t specify which worksheet to target. VBA defaults to the active sheet, which might be your original workbook instead of the new one—this causes errors or unintended changes.

2. Why the Code Runs So Slow #

• Redundant copy loop: You’re copying the entire A1:Y400 range LastRow times—this is totally unnecessary. You only need to copy the used data once, not loop through every row.
• Slow row-by-row deletion: Deleting rows one at a time in a loop is extremely inefficient, especially with large datasets. Using AutoFilter to delete unwanted rows in bulk is way faster.

Fixed VBA Code #

Sub newWB()
    Dim newWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim LastRow As Long
    Dim savePath As String
    Dim fileName As String
    
    ' Set reference to your source worksheet
    Set sourceWS = ThisWorkbook.Worksheets("Pivottabelle")
    
    ' Define save path and a valid filename
    savePath = ThisWorkbook.Path & "\Tru\Sq\"
    fileName = "PivotTable_Output.xlsx" ' Customize this filename as needed
    
    ' Create the save directory if it doesn't exist
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' Create new workbook and set up target worksheet
    Set newWB = Workbooks.Add
    Set targetWS = newWB.Sheets("Sheet1")
    targetWS.Name = "PivotTable"
    
    ' Copy the used data ONCE (no loop needed!)
    LastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
    sourceWS.Range("A1:Y" & LastRow).Copy
    targetWS.Range("A1").PasteSpecial xlPasteAll ' Paste all content (values, formatting, etc.)
    
    ' Delete rows where column H is not "TRU" (using AutoFilter for speed)
    With targetWS
        .AutoFilterMode = False ' Clear any existing filters
        .Range("A1:Y" & LastRow).AutoFilter Field:=8, Criteria1:="<>TRU"
        On Error Resume Next ' Ignore error if no matching rows to delete
        .Range("A2:Y" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0 ' Reset error handling
        .AutoFilterMode = False ' Turn off the filter
    End With
    
    ' Save the new workbook correctly
    newWB.SaveAs Filename:=savePath & fileName, FileFormat:=xlOpenXMLWorkbook
    newWB.Close SaveChanges:=False ' Optional: close the new workbook after saving
End Sub

Key Improvements Explained #

• Removed redundant copy loop: We now copy only the exact used range (up to LastRow) once, which eliminates most of the 5-minute runtime.
• Bulk row deletion: Using AutoFilter to delete unwanted rows in one operation is exponentially faster than deleting rows one by one.
• Automatic directory creation: Checks if the save path exists and creates it if missing, preventing save errors.
• Valid filename & explicit format: Added a proper filename and specified xlOpenXMLWorkbook to ensure a valid .xlsx save.
• Qualified references: All cell/range calls are explicitly tied to the source or target worksheet, eliminating confusion between workbooks.

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