Excel VBA bubble sort 2 key sorts

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.
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,334
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:

Excelgreenhand

Board Regular
Joined
Oct 18, 2009
Messages
101
Thanks for the suggestion. I need the BUBBLE SORT for this case.
Any other suggestions/advice. Thanks.
 

GTO

MrExcel MVP
Joined
Dec 9, 2008
Messages
6,154
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:

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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:

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,714
Office Version
2010
Platform
Windows
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​
 

Excelgreenhand

Board Regular
Joined
Oct 18, 2009
Messages
101
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!
 

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,714
Office Version
2010
Platform
Windows
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.
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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:

Forum statistics

Threads
1,081,619
Messages
5,360,064
Members
400,566
Latest member
Usr3

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top