Sub Portfolios()
Dim X As Long, Z As Long, Ar As Range, Data As Range, Result As Variant
Set Data = Columns("A").SpecialCells(xlConstants)
ReDim Result(1 To Data.Areas.Count, 1 To 1)
With CreateObject("Scripting.Dictionary")
For Each Ar In Data.Areas
X = X + 1
For Z = 1 To Ar.Rows.Count
.Item(Mid(Ar(Z).Value, InStrRev(Ar(Z).Value, " "))) = 1
Next
Result(X, 1) = CommonStart(Ar) & " " & Join(.Keys)
.RemoveAll
Next
End With
Range("B1").Resize(UBound(Result)) = Result
End Sub
Function CommonStart(ByVal V As Variant) As String
Dim X As Long, L As Long, Letter As String
If VarType(V) = vbString Then
V = Split(V, ",")
ElseIf TypeOf V Is Range Then
If V.Rows.Count > 1 And V.Columns.Count > 1 Then
Exit Function
ElseIf V.Rows.Count > 1 Then
V = Application.Transpose(V)
ElseIf V.Columns.Count > 1 Then
V = Application.Index(V.Value, 1, 0)
Else
Exit Function
End If
ElseIf Not IsArray(V) Then
Exit Function
End If
Do
L = L + 1
Letter = Mid(V(LBound(V)), L, 1)
For X = LBound(V) To UBound(V)
If Mid(V(X) & X, L, 1) <> Letter Then
If Len(Letter) Then
CommonStart = RTrim(Left(V(LBound(V)), InStrRev(Left(V(LBound(V)), L), " ")))
Else
CommonStart = V(LBound(V))
End If
Exit Function
End If
Next
Loop While Len(Letter)
End Function
What does that mean? Remember, we know nothing about your data, so telling us your example is "not exact" does not really help us to know what we need to have our code give back to you.
