VBA表格处理：仅保留CAD相关行的代码优化求助

需求说明 #

需要优化现有VBA代码中Subscription工作表的行删除逻辑，具体规则：

• 在A列从包含“TRUE”的起始行到“TRUE Total”的结束行区间内，删除B列出现“CAD”之前的所有行
• 保留B列为“CAD”的行及其下方3行（共4行），删除这4行之后到“TRUE Total”行之前的所有行

原代码问题分析 #

原删除逻辑存在以下问题：

1. 逐行删除时行号会动态变化，导致循环逻辑混乱，容易漏删或误删
2. 硬编码起始遍历行号（比如从第3行、第7行开始），无法适配数据位置变化的情况
3. 未准确定位“TRUE”到“TRUE Total”的完整区间，逻辑边界不清晰

优化后的完整代码 #

Sub XXX()
Dim filePath As String
Dim wb As Workbook
Dim wsResult As Worksheet, wsSubscription As Worksheet, wsRedemption As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim trueStartRow As Long, cadRow As Long, trueTotalRow As Long
    
    ' Step 1: 提示打开文件
    filePath = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
    If filePath = "False" Then Exit Sub
    
    ' Step 2: 打开工作簿和工作表
    Set wb = Workbooks.Open(filePath)
    Set wsResult = wb.Sheets("Result")
    
    ' Step 3: 复制粘贴A:D列的值与格式
    wsResult.Range("A:D").Copy
    wsResult.Range("A:D").PasteSpecial xlPasteValuesAndNumberFormats
    
    ' Step 4: 创建Subscription和Redemption工作表
    Set wsSubscription = wb.Sheets.Add(After:=wsResult)
    wsSubscription.Name = "Subscription"
    Set wsRedemption = wb.Sheets.Add(After:=wsSubscription)
    wsRedemption.Name = "Redemption"
    
    ' Step 5: 复制行至Subscription工作表
    lastRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row
    For i = 3 To lastRow
        If wsResult.Cells(i, "A").Value = "TRUE Total" Then Exit For
        wsResult.Rows(i).Copy wsSubscription.Cells(i - 2, 1)
    Next i

    ' Step 6: 优化后的Subscription工作表行删除逻辑
    With wsSubscription
        ' 定位TRUE起始行（A列第一个包含"TRUE"的行）
        trueStartRow = .Columns("A").Find(What:="TRUE", LookIn:=xlValues, LookAt:=xlWhole).Row
        ' 定位CAD行（B列第一个"CAD"的行）
        cadRow = .Columns("B").Find(What:="CAD", LookIn:=xlValues, LookAt:=xlWhole).Row
        ' 定位TRUE Total行
        trueTotalRow = .Columns("A").Find(What:="TRUE Total", LookIn:=xlValues, LookAt:=xlWhole).Row
        
        ' 删除CAD之前的行（在TRUE到CAD区间内）
        If trueStartRow < cadRow Then
            .Rows(trueStartRow & ":" & cadRow - 1).Delete
            ' 删除后CAD行号会变化，重新计算CAD行和TRUE Total行的位置
            cadRow = cadRow - (cadRow - trueStartRow)
            trueTotalRow = trueTotalRow - (cadRow - trueStartRow)
        End If
        
        ' 删除CAD及其下方3行之后到TRUE Total之前的行
        If cadRow + 4 < trueTotalRow Then
            .Rows(cadRow + 4 & ":" & trueTotalRow - 1).Delete
        End If
    End With

    ' Step 7: 复制行至Redemption工作表
    For i = 1 To lastRow
        If wsResult.Cells(i, "A").Value = "FALSE" Then Exit For
    Next i
    For j = i To lastRow
        If wsResult.Cells(j, "A").Value = "Grand Total" Then Exit For
    Next j
    wsResult.Rows(i & ":" & j).Copy wsRedemption.Cells(1, 1)
    
    ' Step 8: 为Redemption工作表添加公式
    For i = 3 To wsRedemption.Cells(wsRedemption.Rows.Count, "A").End(xlUp).Row Step 4
        wsRedemption.Cells(i, "E").Formula = "=CONCATENATE(""REDS-"", $B$" & (i + 1) & ", "" NEW"")"
    Next i
    
    ' Step 9: 在Redemption工作表中隐藏B列为USD的行
    lastRow = wsRedemption.Cells(wsRedemption.Rows.Count, "B").End(xlUp).Row
    For i = 1 To lastRow
        If wsRedemption.Cells(i, "B").Value = "USD" Then
            wsRedemption.Rows(i).Resize(4).EntireRow.Hidden = True
            i = i + 4 ' 跳过接下来的3行隐藏行
        End If
    Next i
    
    ' Step 10: 删除Result工作表中的A:E列
    wsResult.Range("A:E").Delete xlShiftToLeft
    
    ' Step 11: 从Subscription工作表复制行到Result工作表
    wsSubscription.Rows("1:5").Copy wsResult.Cells(3, 1)
    
    ' Step 12: 从Redemption工作表复制行到Result工作表
    lastRow = wsRedemption.Cells(wsRedemption.Rows.Count, "A").End(xlUp).Row
    For i = 1 To lastRow
        If wsRedemption.Cells(i, "A").Value = "Grand Total" Then Exit For
    Next i
    wsRedemption.Rows("1:" & i).Copy wsResult.Cells(wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 5, 1)
    
    ' Step 13: 调整列宽
    wsResult.Columns("A:E").AutoFit
    
    ' Step 14: 设置列格式
    wsResult.Columns("A:C").NumberFormat = "General"
    wsResult.Columns("E").NumberFormat = "General"
    wsResult.Columns("D").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    
    ' Step 15: 删除Subscription和Redemption工作表
    Application.DisplayAlerts = False ' 抑制确认对话框
    On Error Resume Next ' 忽略工作表不存在的错误
    wb.Sheets("Subscription").Delete
    wb.Sheets("Redemption").Delete
    On Error GoTo 0 ' 重置错误处理
    Application.DisplayAlerts = True
    
    ' Step 16: 切换至Result工作表
    wsResult.Activate
    
    ' Step 17: 提示保存文件
    Dim savePath As String
    savePath = Application.GetSaveAsFilename(InitialFileName:="YourFileName.xlsx", FileFilter:="Excel Files (*.xlsx), *.xlsx")
    If savePath <> "False" Then
        Application.Dialogs(xlDialogSaveAs).Show savePath, xlOpenXMLWorkbook
    End If

End Sub

优化点说明 #

1. 精准定位关键行：用Find方法定位TRUE起始行、CAD行、TRUE Total行，避免硬编码行号，适配数据位置变化
2. 批量删除行：直接通过行号区间批量删除，比逐行删除效率更高，也避免了行号动态变化导致的逻辑错误
3. 动态调整行号：删除行后重新计算CAD行和TRUE Total行的位置，确保后续操作的准确性
4. 边界判断：添加区间有效性判断，避免因数据缺失导致的运行错误

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