マクロ：条件に基づいて最初の列のセルに関連付けられた行のグループを削除し、空白の行を削除します。

Question

目標を達成するためにコードをマージするのが難しいです。 1つのワークブック内で2枚のシートの間で作業しています。列「A」は、列「C」内に複数の行を有するアイテムを参照する。 "C"には何千ものラベルコードが含まれていますが、シートコード "SheetCode"には52個のラベルコードがあります。私の目標は、アイテムを見て、それが52のラベルコードの1つを持っているかどうかを確認し、そうであれば、そのアイテムとその下のすべての行を列 "A"のラベル番号の次のアイテムまで削除します。私はしたい私のマクロへ：シート「SheetCode」に記載されている任意の値の

1. 検索列C（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 

SheetCode;

メインワークシート

Answer 1

を目標とする値あなたは配列し、それが完了することができ、ワークシート関数の一部を使用して、正しい軌道に乗っています。キーは、個々の行ではなく「項目ゾーンごとに」逆方向に反復することです。各項目ゾーンについて、SheetCodeリストで少なくとも1つのコードが一致すると、ゾーン全体が削除されます。

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