VBA MultiDimensional Bubble Sort

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Hi, Is it possible to sort columns via a bubble sort rather than excels standard sort? I am currently sorting columns using a helper column and I want to eliminate the helper columns process. It's basically an Alphanumeric sort which sorts by letter and/or number, the columns sort by A to Z / lowest to highest

I copy the original column to Column AA then Split the data into separate columns on the same row, then sort the columns to sort the original column of data

My code is below

VBA Code:
Option Explicit
Option Compare Text
Dim Match, Matches
Dim Arr As Variant
Dim MatchCount As Long, k As Long
Dim SortRng As Range, Fnd As Range, Rng As Range, Rng2 As Range, xVal As Range

Sub AlphaSort()
'Sorts AlphaNumerically (Decadence 01/2019)

    If ActiveSheet Is Nothing Then
        MsgBox "No Sheets"
        Exit Sub
    End If
    Arr = Array("References", "Reference", "Ref's", "Refs", "Ref", "Ref-Designator", "MfrComments", "MfrComment", "MfgComments", "MfgComment")
    For k = LBound(Arr) To UBound(Arr)
        Set Fnd = ActiveSheet.Columns.Find(What:=Arr(k), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set Rng = Range(Fnd.Offset(1), Cells(Rows.count, Fnd.Column).End(xlUp))
            Exit For
        End If
    Next k
    If Rng Is Nothing Then
        Exit Sub
    End If
    Rng.Copy Range("AA" & Rng.row)
    On Error Resume Next
    With CreateObject("VBScript.RegExp")
        .Pattern = "(\d+|\D+)"
        .Global = True
        LR = Range("A" & Rows.count).End(xlUp).row
        Set Rng2 = Range("AA1:AA" & LR).SpecialCells(xlCellTypeVisible)
        For Each xVal In Rng2
            Set Matches = .Execute(xVal.Value)
            For MatchCount = 1 To Matches.count
                xVal.Offset(, MatchCount).Value = Matches(MatchCount - 1)
            Next MatchCount
        Next xVal
    End With
    If IsEmpty(Rng2.Value) Then
        Exit Sub
    Else
        Range("AA1").EntireColumn.Delete
        Columns("AA:AG").Replace "_", "", xlPart
        Set SortRng = Range("AA1:AG" & LR).SpecialCells(xlCellTypeBlanks)
        SortRng.Rows.Delete Shift:=xlToLeft
        On Error Resume Next
        If Range("A1").Value Like "Ref*" Or Range("A1").Value Like "Mfr*" Or Range("A1").Value Like "Mfg*" Then
            With ActiveSheet
                .Sort.SortFields.Clear
                .Sort.SortFields.Add key:=Range("AA2:AA" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AB2:AB" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AC2:AC" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AD2:AD" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AE2:AE" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AF2:AF" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AG2:AG" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SetRange Range("A2:AG" & LR)
                .Sort.Header = xlGuess
                .Sort.MatchCase = False
                .Sort.Orientation = xlTopToBottom
                .Sort.SortMethod = xlPinYin
                .Sort.Apply
            End With
        Else
            With ActiveSheet
                .Sort.SortFields.Clear
                .Sort.SortFields.Add key:=Range("AA3:AA" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AB3:AB" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AC3:AC" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AD3:AD" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AE3:AE" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AF3:AF" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SortFields.Add key:=Range("AG3:AG" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                .Sort.SetRange Range("A3:AG" & LR)
                .Sort.Header = xlGuess
                .Sort.MatchCase = False
                .Sort.Orientation = xlTopToBottom
                .Sort.SortMethod = xlPinYin
                .Sort.Apply
            End With
        End If
    End If
    Range("AA1").Resize(, 10).EntireColumn.Delete
End Sub

Example to Use code on

RefDetailsQuantity
D1Apples3
R1Bananas 4
C1Pears7
D2Oranges6
 

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
46,784
Office Version
  1. 365
Platform
  1. Windows
Not that it is critical to my suggestion, but are you sure that is your actual code? Asking because you have Option Explicit but variable "LR" used in the code is undeclared.

I am not sure I have understood what you are trying to do but see if this is any use. I have allowed for each text/numerical section of the Ref to be up to 10 characters & just working on columns A:C

VBA Code:
Sub Custom_Sort()
  Dim AL As Object, RX As Object
  Dim a As Variant, itm As Variant
  Dim i As Long
  Dim s As String
 
  Set AL = CreateObject("System.Collections.ArrayList")
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\d+|\D+"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    s = ""
    For Each itm In RX.Execute(a(i, 1))
      If IsNumeric(Left(itm, 1)) Then
        s = s & Right(String(10, " ") & itm, 10)
      Else
        s = s & Left(itm & String(10, " "), 10)
      End If
    Next itm
    If Not AL.Contains(s) Then AL.Add s
  Next i
  AL.Sort
  itm = AL.ToArray
  s = Replace(Join(itm, ","), " ", "")
  With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="""," & s & """", DataOption:=xlSortNormal
    .SetRange Range("A2").Resize(UBound(a), 3)
    .Header = xlNo
    .Apply
  End With
End Sub


Before

decadence 1.xlsm
ABC
1RefDetailsQuantity
2CAX202BBOranges6
3CCDE1Pears7
4DA107Apples3
5R1Bananas4
6CCDE1Peaches100
7CAX22BBApricots500
8CCCCCCCCCC555555555Cherries77
Sheet1



After

decadence 1.xlsm
ABC
1RefDetailsQuantity
2CAX22BBApricots500
3CAX202BBOranges6
4CCCCCCCCCC555555555Cherries77
5CCDE1Pears7
6CCDE1Peaches100
7DA107Apples3
8R1Bananas4
Sheet1
 

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Hi Peter, Yes I am Sure this is my code I am using, I had help from someone on here (a while ago, MickG I think) for the Reg Ex part which I altered to fit my criteria. Also LR is not declared because I forgot to add it in to the post where as my actual code "LR" is a global declaration (As Long) in a separate module within the Custom Ribbon I'm using, so I can write code without having to dim everything when adding new code.

Anyway....The code you posted works Perfectly, Thank You
 

Watch MrExcel Video

Forum statistics

Threads
1,112,814
Messages
5,542,649
Members
410,566
Latest member
Jonniehoffman
Top