VBA MultiDimensional Bubble Sort

[decadence]

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

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

Ref	Details	Quantity
D1	Apples	3
R1	Bananas	4
C1	Pears	7
D2	Oranges	6

 

[Peter_SSs]

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

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
	A	B	C
1	Ref	Details	Quantity
2	CAX202BB	Oranges	6
3	CCDE1	Pears	7
4	DA107	Apples	3
5	R1	Bananas	4
6	CCDE1	Peaches	100
7	CAX22BB	Apricots	500
8	CCCCCCCCCC555555555	Cherries	77
Sheet1

After

decadence 1.xlsm
	A	B	C
1	Ref	Details	Quantity
2	CAX22BB	Apricots	500
3	CAX202BB	Oranges	6
4	CCCCCCCCCC555555555	Cherries	77
5	CCDE1	Pears	7
6	CCDE1	Peaches	100
7	DA107	Apples	3
8	R1	Bananas	4
Sheet1

 

[decadence]

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

 

[Peter_SSs]

"LR" is a global declaration (As Long) in a separate module

OK, fair enough.

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

Good news! Thanks for the confirmation.