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

我很难合并代码来完成我的目标。 我正在两个工作表之间工作。 列“A”引用可能在列“C”中具有多行的项目。 “C”可以有数千个标签代码，但在“SheetCode”表中列出了52个标签代码。 我的目标是看一个项目，看它是否有52个标签代码之一，如果是，则删除项目和它下面的所有行，直到列“A”标签号中的下一个项目。 我想我的macros：

1. 在列表“SheetCode”（A2：A53）中列出的任何值search列C
2. 如果find，则引用A列中的关联填充单元格，并删除以下所有行，直到它运行到A列中的下一个填充单元格，但继续search列“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 

SheetCode; 价值目标

主要工作表

Answer 1

你在正确的轨道上，有一些使用数组和工作表函数可以完成; 关键是我们将“逐项区域”向后迭代，而不是逐行迭代。 对于每个项目区域，如果在SheetCode列表中至less有一个代码匹配，则会删除整个区域。

 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