Sub TestIt()
Const TA As String = "A"
Const TB As String = "B"
Const ZW As Long = 2
Dim rngFind As Range
Dim rngArea As Range
Dim rngPart As Range
Dim arrRw() As Long
Dim rw As Long
Dim x As Integer
Application.ScreenUpdating = False
With Columns(1)
Set rngFind = .Find(TA)
If Not rngFind Is Nothing Then
Set rngArea = .ColumnDifferences(Comparison:=rngFind)
For Each rngPart In rngArea.Areas
If rngPart.Cells(1).Value = TB Then
ReDim Preserve arrRw(x)
arrRw(x) = rngPart.Cells(1).Row
x = x + 1
End If
Next rngPart
End If
For x = UBound(arrRw) To LBound(arrRw) Step -1
rw = .Cells(Rows.Count).End(xlUp).Row
Set rngPart = Range(Rows(arrRw(x)), Rows(rw))
rngPart.Copy Destination:=.Cells(arrRw(x) + ZW)
Range(Rows(arrRw(x)), Rows(arrRw(x) + ZW - 1)).Clear
Range(Rows(arrRw(x)), Rows(arrRw(x) + ZW - 1)).Interior.Color = RGB(100, 100, 100)
Next x
End With
Application.ScreenUpdating = True
End Sub