Sub carlmon()
Dim D As Range
Dim E As Range
Dim F As Range
Dim G As Range



    For Each c In Sheet1.Range("B6:B1000")
    
        Set D = Sheet1.Range("D" & Rows.Count).End(xlUp)
        Set E = Sheet1.Range("E" & Rows.Count).End(xlUp)
        Set F = Sheet1.Range("F" & Rows.Count).End(xlUp)
        Set G = Sheet1.Range("G" & Rows.Count).End(xlUp)
        
        Select Case Left(c, 2)
        Case Is = "AB"
            Set D = D.Offset(1)
            D = c.Value
        Case Is = "BC"
            Set E = E.Offset(1)
            E = c.Value
        Case Is = "CD"
            Set F = F.Offset(1)
            F = c.Value
        Case Is = "DE"
            Set G = G.Offset(1)
            G = c.Value
        End Select
    Next c

End Sub

Sub blah()
StartChars = Array("AB", "BC", "CD", "DE") 'what you're looking for
Set Destn = Range("D2")    'top left of area where results will go.
'Find range to process:
Set Rng = Range("B6").End(xlDown)
If IsEmpty(Rng.Value) Then
  Set Rng = Range("B6")
Else
  Set Rng = Range(Range("B6"), Rng)
End If
'Create the results in-memory:
ReDim Results(1 To UBound(StartChars) - LBound(StartChars) + 1)
For Each cll In Rng.Cells
  colm = Application.Match(Left(Application.Trim(cll.Value), 2), StartChars, 0)
  If Not IsError(colm) Then
    If IsEmpty(Results(colm)) Then Set Results(colm) = CreateObject("Scripting.Dictionary")
    Results(colm).Add cll.Value & Rnd, cll.Value
  End If
Next cll
colm = 0
'determine size of area to clear for the results:
maxRows = 0
For Each result In Results
  maxRows = Application.Max(result.Count, maxRows)
Next result
'clear that area (+1 blank row):
Destn.Resize(maxRows + 1, UBound(Results)).Clear
For Each result In Results
  Destn.Offset(, colm).Resize(result.Count).Value = Application.Transpose(result.items)
  colm = colm + 1
Next result
End Sub