VBA Range.Sort with arrays. Alternative for simple use.

[DocAElstein]

link to this post https://excelfox.com/forum/showthrea...age3#post15513
https://excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use/page3#post15513

---

Sub Take3()
Rem 1 data
Dim Ay() As Variant
Dim Eye As Long, AyeAye As Long, Kay As Long
 Let Ay() = Range("Q1").CurrentRegion.Value2
Rem 2 Do It
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary")
    For Eye = LBound(Ay(), 1) To UBound(Ay(), 1)
        For AyeAye = LBound(Ay(), 1) To UBound(Ay(), 1)
         If Ay(Eye, 1) = Ay(AyeAye, 1) Then
          Let Kay = Kay + 1
          'Let Bea(Kay) = Ay(Eye, 1)
            If Not Dik.exists(BubSrt(Ay(Eye, 1))) Then Dik.Add Key:=Ay(Eye, 1), Item:="AnyThong"
         Else
          Let Kay = Kay + 1
          'Let Bea(Kay) = Ay(Eye, 1) & Ay(AyeAye, 1)
            If Not Dik.exists(BubSrt(Ay(Eye, 1) & Ay(AyeAye, 1))) Then Dik.Add Key:=Ay(Eye, 1) & Ay(AyeAye, 1), Item:="AnyThong"
         End If
        Next AyeAye
    Next Eye

 Dim UnicBea() As Variant: Let UnicBea() = Dik.Keys()

Rem 3 Output
 Range("S1:T20").ClearContents
 Let Range("T1").Resize(UBound(UnicBea()) + 1, 1).Value2 = Application.Transpose(UnicBea())
 Let Range("T1").Resize(UBound(UnicBea()) + 1, 1).Value2 = Application.Index(UnicBea(), Evaluate("=row(1:" & UBound(UnicBea()) + 1 & ")/row(1:" & UBound(UnicBea()) + 1 & ")"), Evaluate("=row(1:" & UBound(UnicBea()) + 1 & ")"))
End Sub

Sub Take4()
Rem 1 data
Dim Ay() As Variant
Dim Eye As Long, AyeAye As Long, Kay As Long
 Let Ay() = Range("Q1").CurrentRegion.Value2
Rem 2 Do It
Dim strUnic As String: Let strUnic = " "
    For Eye = LBound(Ay(), 1) To UBound(Ay(), 1)
        For AyeAye = LBound(Ay(), 1) To UBound(Ay(), 1)
         If Ay(Eye, 1) = Ay(AyeAye, 1) Then
          Let Kay = Kay + 1
            If InStr(1, strUnic, " " & BubSrt(Ay(Eye, 1)) & " ", vbBinaryCompare) = 0 Then Let strUnic = strUnic & BubSrt(Ay(Eye, 1)) & " "
         Else
          Let Kay = Kay + 1
            If InStr(1, strUnic, " " & BubSrt(Ay(Eye, 1) & Ay(AyeAye, 1)) & " ", vbBinaryCompare) = 0 Then Let strUnic = strUnic & BubSrt(Ay(Eye, 1) & Ay(AyeAye, 1)) & " "
         End If
        Next AyeAye
    Next Eye
 Let strUnic = Mid(strUnic, 2, Len(strUnic) - 2) '  Take off the first and last space

 Dim UnicBea() As String: Let UnicBea = Split(strUnic, " ", -1, vbBinaryCompare)
Rem 3 Output
 Range("S1:T20").ClearContents
 Let Range("T1").Resize(UBound(UnicBea()) + 1, 1).Value2 = Application.Transpose(UnicBea())
 Let Range("T1").Resize(UBound(UnicBea()) + 1, 1).Value2 = Application.Index(UnicBea(), Evaluate("=row(1:" & UBound(UnicBea()) + 1 & ")/row(1:" & UBound(UnicBea()) + 1 & ")"), Evaluate("=row(1:" & UBound(UnicBea()) + 1 & ")"))
End Sub


Function BubSrt(ByVal Thong As String) As String
Dim Buf() As String: Let Buf() = Split(StrConv(Thong, vbUnicode), Chr$(0)): ReDim Preserve Buf(UBound(Buf()) - 1) '  https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
Dim Ey As Long, Jay As Long
Dim Temp As Long
 For Ey = LBound(Buf()) To UBound(Buf()) - 1
    For Jay = Ey + 1 To UBound(Buf())
        If Buf(Ey) > Buf(Jay) Then
         Let Temp = Buf(Jay)
         Let Buf(Jay) = Buf(Ey)
         Let Buf(Ey) = Temp
        End If
    Next Jay
Next Ey
 Let BubSrt = Join(Buf(), "")
End Function