Excel VBA运行生成数万多余行，仅需500行的技术求助

问题根源 #

你的代码存在两个核心问题，直接导致大量多余行生成和删除操作卡顿：

1. WorkPart子过程的行号取值错误：使用.Cells(.Rows.Count, "s").Row会直接获取工作表的最大行号（比如Excel 365是1048576行），导致公式被填充到最后一行，凭空生成大量空行数据。
2. CleanItUp宏的删除逻辑低效且不准确：固定选中500到16万行删除，既没匹配实际数据行位置，又因选中超大区域导致系统卡顿，甚至可能误删有效数据。

修复后的完整代码 #

Option Explicit

Sub FilterOFF()
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
    Selection.AutoFilter
    TurnIn
End Sub

Sub TurnIn()
    'start date S (8D start date), count V (Workdays waiting for part), end count date W (Material Arrived Date)
    Dim lastrow As Long, f As String
    
    f = "=NetworkDays(RC[-3],IF(RC[1]>0,RC[1],Today()),lists!R2C3:R11C3)"
    With ThisWorkbook.Sheets("open")
        lastrow = .Cells(.Rows.Count, "S").End(xlUp).Row
        .Range("V3:V" & lastrow).FormulaR1C1 = f
    End With
    Garantee
End Sub

Sub Garantee()
    'start date T (Garantee Start Date), count date U (Garantee Expires)
    Dim ws As Worksheet
    Dim lRow As Long, i As Long

    Set ws = ThisWorkbook.Sheets("open")
    With ws
        lRow = .Range("s" & .Rows.Count).End(xlUp).Row
        For i = 3 To lRow
            .Range("U" & i).Value = DateAdd("m", 36, .Range("t" & i).Value)
        Next i
    End With
    WorkPart
End Sub

Sub WorkPart()
    'start date W (Material arrived date), count X (workdays since arrival), end count date Y (8D submitted)
    Dim lastrow As Long, f As String
    
    f = "=NetworkDays(RC[-1],IF(RC[1]>0,RC[1],Today()),lists!R2C3:R11C3)"
    With ThisWorkbook.Sheets("open")
        ' 修复：改为取实际有数据的最后一行
        lastrow = .Cells(.Rows.Count, "s").End(xlUp).Row
        .Range("X3:X" & lastrow).FormulaR1C1 = f
    End With
    SubmittedD
End Sub

Sub SubmittedD()
    'start date Y (8D Submission Date), count Z (Workdays since Submitted), end date AA (Customer Closed Date)
    Dim lastrow As Long, f As String
    
    f = "=NetworkDays(RC[-1],IF(RC[1]>0,RC[1],Today()),lists!R2C3:R11C3)"
    With ThisWorkbook.Sheets("open")
        lastrow = .Cells(.Rows.Count, "s").End(xlUp).Row
        .Range("Z3:Z" & lastrow).FormulaR1C1 = f
    End With
    TotalCase
End Sub

Sub TotalCase()
    'start date S (Start date), count AC (Total Workdays), end count date AA (Customer Closed Date)
    Dim lastrow As Long, f As String
    
    f = "=NetworkDays(RC[-10],IF(RC[-2]>0,RC[-2],Today()),lists!R2C3:R11C3)"
    With ThisWorkbook.Sheets("open")
        lastrow = .Cells(.Rows.Count, "S").End(xlUp).Row
        .Range("AC3:AC" & lastrow).FormulaR1C1 = f
    End With
    FilterON
End Sub

Sub FilterON()
    Rows("2:2").AutoFilter ' 优化：去掉不必要的选中操作
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
    CleanItUp
End Sub

Sub CleanItUp()
    Dim ws As Worksheet
    Dim actualLastRow As Long, totalRows As Long
    
    Set ws = ThisWorkbook.Sheets("open")
    ' 获取S列实际有数据的最后一行
    actualLastRow = ws.Cells(ws.Rows.Count, "S").End(xlUp).Row
    
    ' 保留最多500行的需求：若实际数据不足500行，以500行为界删除后续行
    If actualLastRow < 500 Then
        actualLastRow = 500
    End If
    
    totalRows = ws.Rows.Count
    ' 仅删除实际数据行之后的所有空行，避免选中超大区域
    If actualLastRow < totalRows Then
        ws.Rows(actualLastRow + 1 & ":" & totalRows).Delete
    End If
    
    ws.Range("A2").Select
    save
End Sub

Sub save()
    ActiveWorkbook.Save
    MsgBox ("Updated")
End Sub

关键修改说明 #

1. 修复WorkPart的行号计算：将错误的最大行号取值改为End(xlUp).Row，确保公式只填充到有数据的最后一行，从根源杜绝多余行生成。
2. 优化CleanItUp删除逻辑：
   • 动态定位实际数据行，只删除该行之后的空行，大幅减少待删除的行数量，解决卡顿问题
   • 保留你“最多需500行”的需求，若实际数据不足500行，自动以500行为界删除后续行
3. 移除冗余选中操作：比如将Rows("2:2").Select改为直接执行AutoFilter，减少VBA与Excel界面的交互，提升运行效率

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