宏：根據條件刪除第一列中與單元格關聯的行組，然後刪除空行

Question

我在合併代碼時遇到了困難，無法完成我的目標。我在一個工作簿中的兩張工作表之間工作。列「A」引用可能在列「C」中具有多行的項目。 「C」可能有數千個標籤代碼，但是有52個標籤代碼在「SheetCode」表中列出。我的目標是看一個項目，看它是否有52個標籤代碼中的一個，如果是，則刪除項目及其下面的所有行，直到列「A」標籤中的下一個項目爲止。我希望我的宏：

1. 搜索C列於表「SheetCode」列出的任何值（A2：A53）
2. 如果找到，引用在A列中的相關填充細胞及以下刪除所有行，直到它運行到列A中的下一個填充單元格，但繼續搜索列「C」的其餘部分以獲取更多（A2：A53）值。
3. Loop

我發佈了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列表中至少有一個代碼匹配，則會刪除整個區域。

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