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

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
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:

A​
B​
C​
2​
B
7​
1​
3​
C
9​
1​
4​
A
8​
5​
5​
C
1​
1​
6​
A
1​
8​
7​
B
1​
1​
8​
C
5​
5​
9​
C
2​
3​
10​
A
6​
3​
11​
C
1​
3​
12​
C
3​
7​
13​
C
8​
7​
14​
A
1​
4​
15​
B
9​
3​
16​
B
8​
2​

After:

A​
B​
C​
2​
A
1​
4​
3​
A
1​
8​
4​
A
6​
3​
5​
A
8​
5​
6​
B
1​
1​
7​
B
7​
1​
8​
B
8​
2​
9​
B
9​
3​
10​
C
1​
1​
11​
C
1​
3​
12​
C
2​
3​
13​
C
3​
7​
14​
C
5​
5​
15​
C
8​
7​
16​
C
9​
1​
 
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

duteberta
  • Question
VBA Code for Custom Sorting
Replies
2
Views
118
duteberta
duteberta
M
  • Question
Bubble Chart Excel
Replies
1
Views
350
OaklandJim
O
SandsB
  • Question
Sorting when a column or 2 is empty
Replies
1
Views
150
DanteAmor
DanteAmor
T
  • Solved
Error when sorting table - with exact same code that is working elsewhere
Replies
2
Views
67
TheRedCardinal
T
G
  • Solved
Sort by level (macro not working)
Replies
7
Views
131
gomes123
G

Forum statistics

Threads
1,214,585
Messages
6,120,397
Members
448,957
Latest member
Hat4Life

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