Sub Test()
Dim rng As Range, cell As Range
Application.ScreenUpdating = False
With Range([G2], [A65536].End(xlUp)(1, 7))
.EntireRow.Sort Key1:=[B2], Order1:=xlAscending, _
Key2:=[D2], Order2:=xlAscending, Header:=xlNo
.FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],RC[-3],"""")"
.SpecialCells(xlCellTypeFormulas, 2).FormulaR1C1 = "=R[-1]C"
.Offset(, -3) = .Value
.EntireRow.Sort Key1:=[B2], Order1:=xlAscending, _
Key2:=[D2], Order2:=xlAscending, _
Key3:=[E2], Order2:=xlDescending, _
Header:=xlNo
.FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],RC[-2],"""")"
.SpecialCells(xlCellTypeFormulas, 2).FormulaR1C1 = "=R[-1]C"
.Offset(, -2) = .Value
.FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],1,"""")"
With .Offset(, 1)
.FormulaR1C1 = "=IF(R[1]C[-1]=1,RC[-5],RC[-5] &R[1]C)"
.Value = .Value
End With
.SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
End With
Set rng = Range([H2], [H65536].End(xlUp))
For Each cell In rng
cell = UniqueNbrs(cell.Value)
cell = SortNbrs(cell.Value)
Next
With Range([C2], [C65536].End(xlUp))
.Value = .Offset(, 5).Value
End With
[G:H].Delete
Application.ScreenUpdating = True
End Sub
Private Function SortNbrs(origString As String) As String
Dim currentChar As String
Dim sourceNum As Integer
Dim destNum As Integer
For sourceNum = 1 To Len(origString)
currentChar = Mid(origString, sourceNum, 1)
If sourceNum = 1 Then
SortNbrs = currentChar
Else
destNum = 1
While destNum < Len(origString) And currentChar > Mid(SortNbrs, destNum, 1)
destNum = destNum + 1
Wend
SortNbrs = Left(SortNbrs, destNum - 1) & currentChar & Mid(SortNbrs, destNum)
End If
Next sourceNum
End Function
Public Function UniqueNbrs(ByVal origString As String) As String
Dim oCol As New Collection
Dim sAns As String
Dim lCtr As Long, lCount As Long
Dim sChar As String
lCount = Len(origString)
For lCtr = 1 To lCount
sChar = Mid(origString, lCtr, 1)
On Error Resume Next
oCol.Add sChar, sChar
If Err.Number = 0 Then sAns = sAns & sChar
Err.Clear
Next
UniqueNbrs = sAns
End Function
