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

Question

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

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

我发布了2张图片。 SheetCode工作表具有值列表。我添加了条件格式，以便主电子表格中的任何单元格值都是彩色的。最后，代码应该删除Column 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

SheetCode;目标值

主要工作表

Answer 1

您已经走上了正确的轨道，可以使用数组和工作表功能来完成它;关键是我们将向后迭代＆＃34;按项目区＆＃34;而不是单独的行。对于每个项目区域，如果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