Also at
https://www.msofficeforums.com/excel...rt-values.html
Code:
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
I suspect I'll give ntldr123 a wide berth in the future since he'll probably already have a solution elsewhere.