VBA代码优化需求：实现仅复制指定区域内的非空行

Got it, let's refine your existing VBA code to only copy rows with actual data in the E:T range. The most efficient approach (especially for large datasets) is to use Excel's built-in AutoFilter to isolate non-empty rows first. Here's how to implement it:

Optimized createSheets Subroutine (AutoFilter Method) #

Sub createSheets(range_Copy As Range, range_Paste As Range)
    Dim sourceData As Range
    Dim filteredNonEmptyRows As Range
    
    ' Set reference to the full source range (E:T)
    Set sourceData = range_Copy
    
    ' Clear any existing filters to avoid conflicts
    sourceData.Parent.AutoFilterMode = False
    
    ' Apply filter to keep only non-empty rows (checks column E, first column in your E:T range)
    sourceData.AutoFilter Field:=1, Criteria1:="<>"
    
    ' Capture only visible (non-empty) rows; error handling for cases with no matching rows
    On Error Resume Next
    Set filteredNonEmptyRows = sourceData.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not filteredNonEmptyRows Is Nothing Then
        ' Copy the filtered non-empty rows
        filteredNonEmptyRows.Copy
        
        ' Paste values and formats to the target location
        With range_Paste
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        
        ' Clear copy mode to free up memory
        Application.CutCopyMode = False
    Else
        ' Alert if no non-empty rows were found
        MsgBox "No non-empty rows detected in the source range!", vbInformation
    End If
    
    ' Turn off the filter to restore the worksheet's original state
    sourceData.Parent.AutoFilterMode = False
End Sub

Key Details: #

• Filter Adjustment: We filter based on column E (the first column in your E:T range, so Field:=1). If you need to check a different column (e.g., column T), adjust the Field number to match its position in E:T (T is the 16th column here, so use Field:=16).
• Error Handling: The On Error blocks prevent crashes if there are no non-empty rows to copy.
• Cleanup: We disable the filter after the operation to leave the source worksheet as it was.

Alternative: Loop Through Rows (For Small Datasets) #

If you're working with a small dataset and prefer a more explicit approach, you can loop through each row and copy only non-empty ones:

Sub createSheets(range_Copy As Range, range_Paste As Range)
    Dim sourceWs As Worksheet
    Dim destWs As Worksheet
    Dim lastSourceRow As Long
    Dim currentRow As Long
    Dim destRow As Long
    
    ' Set references to source and destination worksheets
    Set sourceWs = range_Copy.Parent
    Set destWs = range_Paste.Parent
    destRow = range_Paste.Row ' Start pasting at the target row
    
    ' Find the last row with data in the source range's first column (E)
    lastSourceRow = sourceWs.Cells(sourceWs.Rows.Count, range_Copy.Column).End(xlUp).Row
    
    ' Loop through each row in the source range
    For currentRow = range_Copy.Row To lastSourceRow
        ' Check if the current row (column E) is not empty
        If sourceWs.Cells(currentRow, range_Copy.Column).Value <> "" Then
            ' Copy the E:T range for this row
            sourceWs.Range("E" & currentRow & ":T" & currentRow).Copy
            
            ' Paste values and formats to the destination
            With destWs.Cells(destRow, range_Paste.Column)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
            
            destRow = destRow + 1 ' Move to the next destination row
        End If
    Next currentRow
    
    Application.CutCopyMode = False
End Sub

Your Call Statement Remains Unchanged #

You can keep using your existing call statement—it works perfectly with either version of the subroutine:

Call createSheets(Sheets("Export from QB - Annual Sales").Range("E:T"), Sheets("Sales - " & Sales_Date_Annual).Range("A1"))

内容的提问来源于stack exchange，提问作者G-J