开始删除特定名称的行，并停止特定名称的行

Question

我想重写最近的代码，以清除特定范围内行的内容。这个想法是当ID以上述图例中第一个确定的ID开头时清除范围内的行，并且只有当下一个ID是图例中的第2个确定的ID时，它才应停止删除下一行。 我有2种情况，例如当代码应开始删除时和2种情况应停止时。

有关详细说明，请参见下面的屏幕截图：

这是运行代码之前的情况：

这是我想要得到的结果：

我有另一个很好的问题的代码，但它仅删除图例中指示的ID。如何合并上述条件？

Option Explicit
    Public Sub ClearCells()
Const COLUMN_START1 As Long = 2
Const COLUMN_END1 As Long = 4
Const COLUMN_START2 As Long = 7
Const COLUMN_END2 As Long = 9
Const START_ROW As Long = 8

Dim loopRanges()

loopRanges = Array(COLUMN_START1, COLUMN_END1, COLUMN_START2, COLUMN_END2)

Dim targetSheet As Worksheet, index As Long, unionRng As Range
Dim id As Long
Set targetSheet = ThisWorkbook.Sheets("Sheet1")
Dim ids(), i As Long
ids = targetSheet.Range("D2:D5").Value

Application.ScreenUpdating = False

With targetSheet

    For i = LBound(ids, 1) To UBound(ids, 1)

    For index = LBound(loopRanges) To UBound(loopRanges) Step 2

        Dim lngLastRow As Long, ClearRange As Range, rng As Range

        lngLastRow = .Cells(.Rows.Count, loopRanges(index)).End(xlUp).Row '
        If lngLastRow < START_ROW Then lngLastRow = START_ROW

        Set ClearRange = .Range(.Cells(START_ROW, loopRanges(index)), .Cells(lngLastRow, loopRanges(index + 1)))

        For Each rng In ClearRange.Columns(1).Cells
            If Not IsEmpty(rng) Then
                If Left$(rng.Value, Len(ids(i, 1))) = ids(i, 1) Then '<== match found
                    If Not unionRng Is Nothing Then
                        Set unionRng = Union(unionRng, rng.Resize(1, ClearRange.Columns.Count)) '<== gather all matches into a union range

                    Else
                        Set unionRng = rng.Resize(1, ClearRange.Columns.Count)
                    End If
                End If
            End If
        Next rng
    Next index

    Next i

    End With

    If Not unionRng Is Nothing Then unionRng.ClearContents     Application.ScreenUpdating = True
MsgBox "Done", vbInformation

    End Sub