宏：根据条件删除与第一列中的单元格关联的行组，然后删除空白行

Question

我很难合并代码以实现我的目标。我在一个工作簿中的两张纸之间工作。 “A”列引用了“C”列中可能有多行的项目。 “C”可能有数千个标签代码，但“SheetCode”表中列出了 52 个标签代码。我的目标是查看一个项目，看看它是否具有 52 个标签代码之一，如果是，则删除该项目及其下方的所有行，直到“A”列标签编号中的下一个项目。我希望我的宏：

1. 在 C 列中搜索工作表“SheetCode”(A2:A53) 中列出的任何值
2. 如果找到，请引用 A 列中关联的填充单元格并删除下面的所有行，直到它遇到 A 列中的下一个填充单元格，但继续搜索“C”列的其余部分以获取更多 (A2:A53) 值.
3. 循环

我发布了 2 张图片。 SheetCode 工作表具有值列表。我添加了条件格式，以便主电子表格中的任何单元格值都是彩色的。最终，代码应该删除列 A 值下方的所有行。此示例将显示第 14-21 行和第 29-44 行已删除。

这是我目前所拥有的。我的问题是我想避免

Sub Remove_TBI_AB()
Const TEST_COLUMN As String = "C"
Dim Lastrow As Long
Dim EndRow As Long
Dim i As Long
Application.ScreenUpdating = False

With ActiveSheet

    Lastrow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
    EndRow = Lastrow
    For i = Lastrow To 1 Step -1
        If .Cells(i, TEST_COLUMN).Value2 Like "161000" Then
            'Here I could at continuous "_or" and then in next line add the next code to find, but I have the list and would rather reference the list of values

            .Rows(i & ":" & EndRow).Delete

            EndRow = i - 1
        ' Here I need code to delete all cells below the associated value in Column A until the next populated cell. 

            EndRow = i - 1
        End If
    Next i
End With

Application.ScreenUpdating = True
End Sub

工作表代码；目标值

主工作表

Answer 1

您在正确的轨道上，通过使用数组和工作表函数可以完成它；关键是我们将“按项目区域”而不是按单个行向后迭代。对于每个项目区域，如果SheetCode 列表中至少匹配一个代码，则删除整个区域。

Sub Remove_TBI_AB()
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    On Error GoTo Cleanup

    Dim codes As Range: Set codes = Worksheets("Sheetcode").Range("A2:A53")
    Dim lastrow As Long, startRow As Long
    '[startRow, lastRow] mark the start/end of current item
    With Worksheets("Main")
        lastrow = .Cells(.Rows.count, 3).End(xlUp).row
        Do While lastrow > 1
            startRow = lastrow
            Do Until Len(Trim(.Cells(startRow, 1).Value2)) > 0
                startRow = startRow - 1
            Loop ' find the beginning of current item

            With .Range("C" & startRow & ":C" & lastrow) ' range of current item codes
                If Application.SumProduct(Application.CountIf(codes, .Value2)) > 0 Then
                    .EntireRow.Delete ' at least one code was matched
                End If
            End With
            lastrow = startRow - 1
        Loop ' restart with next item above
    End With

Cleanup:
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationAutomatic
End Sub