Excel VBA bubble sort 2 key sorts

E

Excelgreenhand

Board Regular
Joined
Oct 18, 2009
Messages
101
I would like to use bubble sort (I am ok with only one sorting key) for my Excel data in an array as this
a 10
b 5
a 2
a 5
b 2
and the result to be like this
a 2
a 5
a 10
b 2
b 5
Can it be accomplished? How about 3 sorting keys (or more)
Thanks.
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
It's not clear if the data is in a single column or split across two. If it's in two columns, starting at A1, this works without needing to code or use a bubble sort:
Code: 
Sub Sort_2Cols()

    With Cells(1,1).resize(5, 2)
        .Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), order2:=xlAscending
    End With

End Sub
Which also allows a third key to sort by, but not more.
 
Last edited:
Upvote 0
I would suggest showing the code you are using to sort a single list of values.

Is this for school? Does it have to be a bubble sort specifically, or just a sorting method?
 
Last edited:
Upvote 0
Here is one way !!!
Data in column A/B starting row1.
Code: 
[COLOR=navy]Sub[/COLOR] MG01Sep41
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, temp1 [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] I, J
[COLOR=navy]Dim[/COLOR] temp2 [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] K [COLOR=navy]As[/COLOR] Variant, Temp [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("B" & Rows.Count).End(xlUp))
[COLOR=navy]For[/COLOR] I = 1 To Rng.Columns(1).Cells.Count
    [COLOR=navy]For[/COLOR] J = I To Rng.Columns(1).Cells.Count
        [COLOR=navy]If[/COLOR] Rng(J, 1) < Rng(I, 1) [COLOR=navy]Then[/COLOR]
            temp1 = Rng(I, 1)
            temp2 = Rng(I, 2)
                Rng(I, 1) = Rng(J, 1)
                Rng(I, 2) = Rng(J, 2)
            Rng(J, 1) = temp1
            Rng(J, 2) = temp2
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] J
[COLOR=navy]Next[/COLOR] I
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Columns(1).Cells
    [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        .Add Dn.Value, Dn.Offset(, 1)
    [COLOR=navy]Else[/COLOR]
        [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]
For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    [COLOR=navy]For[/COLOR] I = 1 To .Item(K).Count
        [COLOR=navy]For[/COLOR] J = I To .Item(K).Count
            [COLOR=navy]If[/COLOR] .Item(K)(J) < .Item(K)(I) [COLOR=navy]Then[/COLOR]
                Temp = .Item(K)(I)
                .Item(K)(I) = .Item(K)(J)
                .Item(K)(J) = Temp
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] J
    [COLOR=navy]Next[/COLOR] I
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With

[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Another way:

Code: 
Sub x()
  If Not BubbleSortRange(Range("A2:C16"), 3) Then Exit Sub
  If Not BubbleSortRange(Range("A2:C16"), 2) Then Exit Sub
  If Not BubbleSortRange(Range("A2:C16"), 1) Then Exit Sub
  Beep
End Sub

Function BubbleSortRange(r As Range, iCol As Long) As Boolean
  Dim n             As Long
  Dim i             As Long
  Dim iTop          As Long

  If iCol < 1 Or iCol > r.Columns.Count Then
    MsgBox Prompt:="Sort column out of range!", _
           Title:="BubbleSortRange"
    Exit Function
  End If

  n = r.Rows.Count

  Do
    iTop = 1
    For i = 2 To n
      'r.Rows(i - 1).Resize(2).Select
      If r(i - 1, iCol).Value2 > r(i, iCol).Value2 Then
        r.Rows(i - 1).Cut
        r.Rows(i + 1).Insert
        iTop = i
      End If
    Next i
    n = iTop
  Loop Until n = 1
  
  BubbleSortRange = True
End Function

Before:

[Table="width:, class:grid"][tr][td="bgcolor:#C0C0C0"][/td][td="bgcolor:#C0C0C0"]
A​
[/td][td="bgcolor:#C0C0C0"]
B​
[/td][td="bgcolor:#C0C0C0"]
C​
[/td][/tr][tr][td="bgcolor:#C0C0C0"]
2​
[/td][td]B[/td][td]
7​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
3​
[/td][td]C[/td][td]
9​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
4​
[/td][td]A[/td][td]
8​
[/td][td]
5​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
5​
[/td][td]C[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
6​
[/td][td]A[/td][td]
1​
[/td][td]
8​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
7​
[/td][td]B[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
8​
[/td][td]C[/td][td]
5​
[/td][td]
5​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
9​
[/td][td]C[/td][td]
2​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
10​
[/td][td]A[/td][td]
6​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
11​
[/td][td]C[/td][td]
1​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
12​
[/td][td]C[/td][td]
3​
[/td][td]
7​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
13​
[/td][td]C[/td][td]
8​
[/td][td]
7​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
14​
[/td][td]A[/td][td]
1​
[/td][td]
4​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
15​
[/td][td]B[/td][td]
9​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
16​
[/td][td]B[/td][td]
8​
[/td][td]
2​
[/td][/tr]
[/table]

After:

[Table="width:, class:grid"][tr][td="bgcolor:#C0C0C0"][/td][td="bgcolor:#C0C0C0"]
A​
[/td][td="bgcolor:#C0C0C0"]
B​
[/td][td="bgcolor:#C0C0C0"]
C​
[/td][/tr][tr][td="bgcolor:#C0C0C0"]
2​
[/td][td]A[/td][td]
1​
[/td][td]
4​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
3​
[/td][td]A[/td][td]
1​
[/td][td]
8​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
4​
[/td][td]A[/td][td]
6​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
5​
[/td][td]A[/td][td]
8​
[/td][td]
5​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
6​
[/td][td]B[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
7​
[/td][td]B[/td][td]
7​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
8​
[/td][td]B[/td][td]
8​
[/td][td]
2​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
9​
[/td][td]B[/td][td]
9​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
10​
[/td][td]C[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
11​
[/td][td]C[/td][td]
1​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
12​
[/td][td]C[/td][td]
2​
[/td][td]
3​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
13​
[/td][td]C[/td][td]
3​
[/td][td]
7​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
14​
[/td][td]C[/td][td]
5​
[/td][td]
5​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
15​
[/td][td]C[/td][td]
8​
[/td][td]
7​
[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]
16​
[/td][td]C[/td][td]
9​
[/td][td]
1​
[/td][/tr]
[/table]
 
Upvote 0
Thanks guys for the response.
I may not be clear that I could not alter/change the original data on the worksheet, BUT at the same time I have to present the data after sorting (2 or 3 keys) in
a listbox on a form. (any other idea other than bubble sorting with 2/3 keys !?)
Just pretend a project from a school or old school ...
Thank you ALL!
 
Upvote 0
You can sort by any number of keys, provided you do a stable sort (i.e., don't change the order of records having identical keys), by sorting sequentially in reverse order.
 
Upvote 0
This is an option for columns "A to C" (Can be 2 or more columns as required!!) with results starting "D1" and a line for filling a Listbox.
Code: 
[COLOR=navy]Sub[/COLOR] MG02Sep54
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] K [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] I, J, Temp, Tot [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] P [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range("A1", Range("C" & Rows.Count).End(xlUp))
    [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Columns(1).Cells
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
            .Add Dn.Value, Dn
        [COLOR=navy]Else[/COLOR]
            [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR]
ReDim Ray(1 To Rng.Columns(1).Cells.Count, 1 To Rng.Columns.Count)
Tot = 0
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
     [COLOR=navy]For[/COLOR] Ac = 1 To Rng.Columns.Count
        c = Tot
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] P [COLOR=navy]In[/COLOR] .Item(K).Offset(, Ac - 1)
            c = c + 1
            Ray(c, Ac) = P
        [COLOR=navy]Next[/COLOR] P
        [COLOR=navy]If[/COLOR] Ac > 1 [COLOR=navy]Then[/COLOR]
            Temp = ""
            [COLOR=navy]For[/COLOR] I = Tot + 1 To c
                [COLOR=navy]For[/COLOR] J = I To c
                    [COLOR=navy]If[/COLOR] Ray(J, Ac) < Ray(I, Ac) [COLOR=navy]Then[/COLOR]
                        Temp = Ray(I, Ac)
                        Ray(I, Ac) = Ray(J, Ac)
                        Ray(J, Ac) = Temp
                    [COLOR=navy]End[/COLOR] If
                [COLOR=navy]Next[/COLOR] J
            [COLOR=navy]Next[/COLOR] I
       [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Ac
Tot = c
[COLOR=navy]Next[/COLOR] K
Range("D1").Resize(Tot, Rng.Columns.Count) = Ray
ListBox1.List = Ray
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
Trailing Zero
2
Replies
19
Views
507
awoohaw
awoohaw
T
  • Solved
Can I sort a table by applying columns in a different order to the sort request?
Replies
5
Views
204
TheRedCardinal
T
N
  • Solved
Command buttons not sorting - and sometimes jumping around on sort
2
Replies
10
Views
183
netxtown
N
N
  • Question Question
ActiveX Option Button to sort Data in another sheet and update conbobox
2 3
Replies
22
Views
344
NUC_N_FUTS2
N
L
  • Question Question
VBA - Run time error '9': subscript out of range
Replies
3
Views
271
RoryA
RoryA

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top