VBA复制符合条件行报错Subscript Out of Range问题排查

First, let's diagnose the root cause of the error: the Subscript Out of Range message occurs because your code is trying to access a worksheet named Pivottabelle in the new workbook (instead of the original MyBook where that sheet actually exists) during the loop.

Here are the key fixes and improvements to your code:

Key Issues & Fixes #

• Ambiguous Worksheet Reference: In the loop block, you didn't explicitly specify that Pivottabelle belongs to MyBook. Since the loop is inside a With newBook block, VBA tries to find the sheet in the new workbook (which doesn't exist).
• Incorrect File Format: You're using xlNormal (which saves as .xls) but need .xlsx—use xlOpenXMLWorkbook instead.
• Row Initialization: The initial value of j might skip the first row if the new sheet is empty; starting at j = 1 is safer.

Corrected Code #

Sub OpenBook()
    Dim MyBook As Workbook, newBook As Workbook
    Dim sourceSheet As Worksheet, targetSheet As Worksheet
    Dim FileNm As String
    Dim LastRow As Long
    Dim i As Long, j As Long
    
    Set MyBook = ThisWorkbook
    ' Set reference to source sheet explicitly to avoid ambiguity
    Set sourceSheet = MyBook.Worksheets("Pivottabelle")
    
    ' Define save path and filename for .xlsx
    FileNm = MyBook.Path & "\" & "ProjectList.xlsx"
    
    ' Create new workbook and set target sheet
    Set newBook = Workbooks.Add
    Set targetSheet = newBook.Sheets("Sheet1")
    targetSheet.Name = "PivotTable"
    
    ' Get last row of data in source sheet
    LastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' Initialize target row counter to start at first row
    j = 1
    
    ' Loop through source rows and copy matching ones
    For i = 1 To LastRow
        If sourceSheet.Cells(i, 8).Value = "TRU" Then
            sourceSheet.Rows(i).Copy Destination:=targetSheet.Range("A" & j)
            j = j + 1
        End If
    Next i
    
    ' Save as .xlsx format and close
    newBook.SaveAs Filename:=FileNm, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=True
    newBook.Close SaveChanges:=False
    
    ' Clean up objects
    Set sourceSheet = Nothing
    Set targetSheet = Nothing
    Set newBook = Nothing
    Set MyBook = Nothing
End Sub

Explanation of Changes #

1. Explicit Worksheet References: We declared sourceSheet and targetSheet variables to clearly point to the original and new workbook's sheets. This eliminates any ambiguity that caused the subscript error.
2. File Format Correction: xlOpenXMLWorkbook ensures the file is saved as .xlsx (the modern Excel format) instead of the older .xls.
3. Row Counter Initialization: Starting j at 1 ensures we begin pasting from the first row of the target sheet, even if it's empty.
4. Object Cleanup: Added Set ... = Nothing to release memory used by the workbook/sheet objects, which is good practice in VBA.

This should resolve the Subscript Out of Range error and correctly copy all rows where column 8 is "TRU" to the new workbook's "PivotTable" sheet.

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