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