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

**DocAElstein** · 03-17-2019, 07:05 PM

In the next posts are miscillaneous notes for future referrence

**DocAElstein** · 04-02-2019, 04:03 PM

??? URL link to this post is https://excelfox.com/forum/showthrea...age3#post15512
https://excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use/page3#post15512
https://excelfox.com/forum/showthrea...5512#post15512
https://excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=15512#post15512

Some extra notes for this Thread
https://eileenslounge.com/viewtopic.php?f=30&t=36415
this post
https://eileenslounge.com/viewtopic....d12315#p282569

Data in column Q, outputs Columns S and T
S is like the original macro in the main question
Column T has the output got from my two macros below,
Sub TakeThat1()
Sub TakeThat2()

_____ Workbook: Bubble Sort Demo 1.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	Q	S	T
1	1	1	1
2	2	12	12
3	3	13	13
4		21	2
5		2	23
6		23	3
7		31
8		32
9		3
10

Worksheet: Sorting

Code:

'  https://eileenslounge.com/viewtopic.php?f=30&t=36415           https://eileenslounge.com/viewtopic.php?p=282569&sid=c152f3e01b8240fac89d77316ed12315#p282569     
'
Sub TakeThat1()
Rem 1 data
Dim Ay() As Variant, Bea() As Variant: ReDim Bea(1 To 1000)
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(Bea(Kay))) Then Dik.Add Key:=Bea(Kay), Item:="AnyThong"
         Else
          Let Kay = Kay + 1
          Let Bea(Kay) = Ay(Eye, 1) & Ay(AyeAye, 1)
            If Not Dik.exists(BubSrt(Bea(Kay))) Then Dik.Add Key:=Bea(Kay), 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("S1").Resize(UBound(Bea()) + 1, 1).Value2 = Application.Transpose(Bea())
 Let Range("S1").Resize(10, 1).Value2 = Application.Transpose(Bea())
 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 TakeThat2()
Rem 1 data
Dim Ay() As Variant, Bea() As Variant: ReDim Bea(1 To 1000)
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
          Let Bea(Kay) = Ay(Eye, 1)
            If InStr(1, strUnic, " " & BubSrt(Bea(Kay)) & " ", vbBinaryCompare) = 0 Then Let strUnic = strUnic & BubSrt(Bea(Kay)) & " "
         Else
          Let Kay = Kay + 1
          Let Bea(Kay) = Ay(Eye, 1) & Ay(AyeAye, 1)
            If InStr(1, strUnic, " " & BubSrt(Bea(Kay)) & " ", vbBinaryCompare) = 0 Then Let strUnic = strUnic & BubSrt(Bea(Kay)) & " "
         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("S1").Resize(UBound(Bea()) + 1, 1).Value2 = Application.Transpose(Bea())
 Let Range("S1").Resize(10, 1).Value2 = Application.Transpose(Bea())
 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




Sub Testie() '  https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
Dim Thong As String: Let Thong = "132"
Dim Buf() As String: Let Buf() = Split(StrConv(Thong, vbUnicode), Chr$(0))
ReDim Preserve Buf(UBound(Buf()) - 1)
End Sub
Sub Testie2()
Dim ThingThong As String: Let ThingThong = "132"
 Let ThingThong = BubSrt(ThingThong)
End Sub

**DocAElstein** · 04-21-2019, 04:07 PM

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

Code:

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

**DocAElstein** · 04-22-2019, 12:31 PM

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

Function

required for last two posts

Code:

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