Bubble sort with supertotal in excel VBA

Hello,

So i decided, as i am a good guy, to reprogram my supertotal bubble sort in excel vba

Not that i am a good guy, but everyone think excel is a god, so i had to...

It will generate 3 excel tables with the dataset example (wich you can replace with a sql query)
It will still generate a log file starting with ZZZ
It will still generate a html file with all the tables

Requirements:
microsoft excel 2013
.xlsm extension (file with macro)
Activation of vba macros if excel present a warning

26/07/2015 19:48:14 Start of bubble sort example

TABLE 01 Dataset was sorted with dataset.sort by index field, alphanumeric sorting

Index	item	quantity	description
10b.2c.33b	bolt	18	this is a bolt
11a.1c.3b	bolt	1	this is a bolt
1a.2c.33b	bolt	45	this is a bolt
1b.2c.33	bolt	12	this is a bolt
1c.2c	bolt	5	this is a bolt
1z.10c.3b	bolt	2	this is a bolt

TABLE 02 Split all the values to get only numbers and calculate a supertotal

split01	split02	split03	Number	Letter	Number	Letter	Number	Letter	Supertotal
10b	2c	33b	10	2	2	3	33	2	1,1003003004034E+19
11a	1c	3b	11	1	1	3	3	2	1,2002002004004E+19
1a	2c	33b	1	1	2	3	33	2	2,002003004034E+18
1b	2c	33	1	2	2	3	33	0	2,003003004034E+18
1c	2c		1	3	2	3	0	0	2,004003004001E+18
1z	10c	3b	1	26	10	3	3	2	2,027011004004E+18

TABLE 03 sorted after all was converted to number to make a supertotal

Index	item	quantity	description	Supertotal verification (not in DS)
1a.2c.33b	bolt	45	this is a bolt	2,002003004034E+18
1b.2c.33	bolt	12	this is a bolt	2,003003004034E+18
1c.2c	bolt	5	this is a bolt	2,004003004001E+18
1z.10c.3b	bolt	2	this is a bolt	2,027011004004E+18
10b.2c.33b	bolt	18	this is a bolt	1,1003003004034E+19
11a.1c.3b	bolt	1	this is a bolt	1,2002002004004E+19

---------------------- excel VBA macro (alt F11, add module, insert this code) ---------------------

Sub bubblesort01()

'=== bubblesort_wildboy85.vbs
'=== requirement: wscript.exe
'=== very fast bubble sort
'=== by wildboy85 (sergefournier @ hotmail.com)

'=== objects needed
Set objFSo = CreateObject("Scripting.FileSystemObject")
Set objshe = CreateObject("WScript.Shell")
Set objNet = CreateObject("WScript.Network")

'=== register base constants
Const hkcr = &H80000000 'HKEY_CLASSES_ROOT
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const hklm = &H80000002 'HKEY_LOCAL_MACHINE
Const hku = &H80000003  'HKEY_USERS
Const hkcc = &H80000005 'HKEY_CURRENT_CONFIG

Const ForReading = 1
Const adVarChar = 200
Const MaxCharacters = 255
Const adDouble = 5

'=== actual drive, actual directory, and "\"
'thepath = Application.ActiveWorkbook.path
thepath = Application.ActiveWorkbook.FullName
p = InStrRev(thepath, "\")
basedir = Left(thepath, p)
filnam = Right(thepath, Len(thepath) - p)

'=== log what we do, in same directory as the script
logall = 1
htmlout = 1

If logall = 1 Then
   '=== debug log, get this file name, remove end, change start for ZZZ
   '=== remove .vbs
   path01 = Left(thepath, Len(thepath) - (Len(thepath) - InStr(thepath, ".") + 1))
   name01 = Right(path01, Len(path01) - InStrRev(path01, "\"))
   logname01 = "zzz_" & name01 & ".txt"
   '=== always have a nice error trapping
   err01 = 0: err02 = ""
   On Error Resume Next
   Set file02 = objFSo.OpenTextFile(logname01, 2, True)
   err01 = Err: err02 = Err.Description
   On Error GoTo 0
End If
If err01 = 0 Then
    logall = 1
Else
    '=== flag to tell our program to not write in log file if there is not log file open
    logall = 0 '=== could not open logfile, no log
End If

'=== html output file, we want a nice table as output
If htmlout = 1 Then
   path01 = Left(thepath, Len(thepath) - (Len(thepath) - InStr(thepath, ".") + 1))
   name01 = Right(path01, Len(path01) - InStrRev(path01, "\"))
   logname01 = name01 & "_output.html"
   '=== always have a nice error trapping
   err01 = 0: err02 = ""
   On Error Resume Next
   Set file03 = objFSo.OpenTextFile(logname01, 2, True)
   err01 = Err: err02 = Err.Description
   On Error GoTo 0
End If

If err01 = 0 Then
    htmlout = 1
Else
    '=== flag to tell our program to not write in log file if there is not log file open
    htmlout = 0 '=== could not open logfile, no log
End If

If logall = 1 Then file02.WriteLine Date & " " & Time & " START Bubble sort wildboy85"

'=== the dataset could come from a database, but here we will add data ourseleves as an example
Set dataset01 = CreateObject("ADODB.Recordset")

dataset01.Fields.Append "Index", adVarChar, MaxCharacters
If logall = 1 Then file02.WriteLine Date & " " & Time & " First field appended"

dataset01.Fields.Append "item", adVarChar, MaxCharacters
dataset01.Fields.Append "quantity", adDouble
dataset01.Fields.Append "description", adVarChar, MaxCharacters

'dataset01.Fields.Append "supertotal DS", adVarChar, MaxCharacters

dataset01.Open

'=== accessing the column by name is slow, it would be faster by name if we have big loop
dataset01.AddNew
dataset01("Index") = "11a.1c.3b"
dataset01("item") = "bolt"
dataset01("quantity") = 1
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1z.10c.3b"
dataset01("item") = "bolt"
dataset01("quantity") = 2
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1a.2c.33b"
dataset01("item") = "bolt"
dataset01("quantity") = 45
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1b.2c.33"
dataset01("item") = "bolt"
dataset01("quantity") = 12
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "1c.2c"
dataset01("item") = "bolt"
dataset01("quantity") = 5
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.AddNew
dataset01("Index") = "10b.2c.33b"
dataset01("item") = "bolt"
dataset01("quantity") = 18
dataset01("description") = "this is a bolt"
dataset01.Update

dataset01.movefirst
'=== how many field? (columns)
fieldscount01 = dataset01.Fields.Count

'=== put the dataset demo in excel page (first) as a table
Dim myarray As Variant
array01 = dataset01.GetRows

'=== get number of rows (dimension 2 of the array)
On Error Resume Next
err01 = 0: err02 = ""
rowcount01 = UBound(array01, 2)
err01 = Err
err02 = Err.Description
On Error GoTo 0

If err01 = 0 Then
 
    '=== 2 dimension in array, we continue (2 row of data is a minimum)
    Set Sheet01 = Worksheets(1)
 
    '=== delete old table01 if it exist
    tablename01 = "table01"
    On Error Resume Next
    err01 = 0: err02 = ""
    Sheet01.ListObjects(tablename01).Delete
    err01 = Err
    err02 = Err.Description
    On Error GoTo 0
 
    x = 1: y = 1
 
    '=== columns names
    For i = 0 To fieldscount01 - 1
        Cells(y, x + i).Value = dataset01.Fields(i).Name
    Next
 
    '=== range01 include column title
    Set Range01 = Range(Cells(y, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
    '=== range02 is data only
    Set Range02 = Range(Cells(y + 1, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
    Range02.Value = Application.WorksheetFunction.Transpose(array01)
     
    Sheet01.ListObjects.Add(xlSrcRange, Range01, , xlYes).Name = tablename01
 
    If logall = 1 Then file02.WriteLine Date & " " & Time & " fieldcount: " & fieldscount01
 
    If htmlout = 1 Then file03.WriteLine Date & " " & Time & " Start of bubble sort example<br><br>"
 
    '=== this datasort will order our items badly, as if number 10 was smaller than number 1
    dataset01.Sort = "index"
 
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '   excel table02 sorted with dataset sort command (as string)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
    '=== read dataset that was sorted as string
    array01 = dataset01.GetRows
 
    '=== delete old table01 if it exist
    tablename01 = "table02"
    On Error Resume Next
    err01 = 0: err02 = ""
    Sheet01.ListObjects(tablename01).Delete
    err01 = Err
    err02 = Err.Description
    On Error GoTo 0
 
    x = 1: y = (4 + rowcount01) * 1
 
    '=== columns names
    For i = 0 To fieldscount01 - 1
        Cells(y, x + i).Value = dataset01.Fields(i).Name
    Next
 
    '=== range01 include column title
    Set Range01 = Range(Cells(y, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
    '=== range02 is data only
    Set Range02 = Range(Cells(y + 1, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
    Range02.Value = Application.WorksheetFunction.Transpose(array01)
     
    Sheet01.ListObjects.Add(xlSrcRange, Range01, , xlYes).Name = tablename01
     
    '=== html table
    If htmlout = 1 Then file03.WriteLine " TABLE 01 Dataset was sorted with dataset.sort by index field, alphanumeric sorting<br>"
    If htmlout = 1 Then file03.WriteLine "<table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"
 
    '=== fields names as columns titles of the table
    If htmlout = 1 Then file03.WriteLine "<tr>"
    For i = 0 To fieldscount01 - 1
        If htmlout = 1 Then file03.WriteLine "<td>" & dataset01.Fields(i).Name & "</td>"
    Next
    If htmlout = 1 Then file03.WriteLine "</tr>"
 
    dataset01.movefirst
    linecount = 0
    Dim ara02()
 
    Do While Not (dataset01.EOF) '=== magica loop, row
        ReDim Preserve ara02(fieldscount01 - 1, linecount)
 
        If htmlout = 1 Then file03.WriteLine "<tr>"
     
        '=== put all values in an array, because a dataset this basic cannot switch a line of data
        For i = 0 To fieldscount01 - 1
            value01 = dataset01.Fields(i).Value
            If IsNull(value01) Then value01 = ""
            value01 = Trim(value01)
 
            If htmlout = 1 Then file03.WriteLine "<td>" & value01 & "</td>"
     
            ara02(i, linecount) = value01
        Next
        If htmlout = 1 Then file03.WriteLine "</tr>"
        linecount = linecount + 1
        dataset01.movenext
    Loop
 
    If htmlout = 1 Then file03.WriteLine "</table><br>"
     
    '=== now we will split the line we will use to do the sort by number and letter (converted to numbers)
    fieldtosort01 = 0 '=== field 0 contain what we want to sort, example: 1a.2b.3c
 
    '=== we assume we will have only 3 data to sort, 1a 2b 3c
    dataset01.movefirst
    If htmlout = 1 Then file03.WriteLine "<br>TABLE 02 Split all the values to get only numbers and calculate a supertotal"
    If htmlout = 1 Then file03.WriteLine "<table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"
    If htmlout = 1 Then file03.WriteLine "<tr><td>split01</td><td>split02</td><td>split03</td>"
    If htmlout = 1 Then file03.WriteLine "<td>Number</td><td>Letter</td><td>Number</td><td>Letter</td><td>Number</td><td>Letter</td>"
    If htmlout = 1 Then file03.WriteLine "<td>Supertotal</td></tr>"
 
    '=== split the chain 1a.2b.3c by adding dots in case 2b.3c does not exist
    Dim split(2)
    linecount = 0
    Dim ara01()
 
    Do While Not (dataset01.EOF) '=== magica loop, row
        ReDim Preserve ara01(6, linecount) '=== the last dimension can be redimensionned so we reversed the dimensions
     
        If htmlout = 1 Then file03.WriteLine "<tr>" '=== html line change
     
        value01 = dataset01.Fields(fieldtosort01).Value
        '=== clean value in case of dbnull (dbnull cannot be processed)
        If IsNull(value01) Then value01 = ""
        value01 = Trim(value01)
     
        '=== add dots at the end of string to later split at the dots and get string inbetween
        '=== so if the string have no dots, the split will still work and resturn empty string instead of trying to trap errors
        value01 = value01 & "...."
        split(0) = Left(value01, Len(value01) - (Len(value01) - InStr(value01, ".") + 1))
        leftover = Mid(value01, InStr(value01, ".") + 1, Len(value01))
        split(1) = Left(leftover, Len(leftover) - (Len(leftover) - InStr(leftover, ".") + 1))
        leftover = Mid(leftover, InStr(leftover, ".") + 1, Len(leftover))
        split(2) = Left(leftover, Len(leftover) - (Len(leftover) - InStr(leftover, ".") + 1))
        If htmlout = 1 Then file03.WriteLine "<td>" & split(0) & "</td><td>" & split(1) & "</td><td>" & split(2) & "</td>"
     
        '=== we now do an array of 6 fields/columns
        '=== field0 is 1, field1 is a, field2 is 2, field3 is b, field4 is 3, field5 is c (from 1a.2b.3c)
        splitcount = 0
        For x03 = 0 To 5 Step 2 'order01, order01 letter, order02, order02 letter, order03, order03 letter (letter --> integer)
            '=== split the split to get 2 value, 1 for number, 1 for alpha (split the chain "1a", "2b", "3c")
            data01 = Trim(split(splitcount))
            len01 = Len(data01)
            If len01 > 1 Then
                alpha01 = 0
                For i = 1 To len01
                    '=== is this digit alpha?
                    asc01 = Asc(Mid(data01, i, 1))
                    If (asc01 > 64 And asc01 < 91) Or (asc01 > 96 And asc01 < 123) Then
                        alpha01 = 1
                        '=== this is a letter
                        If i > 1 Then
                            val01 = CInt(Left(data01, i - 1))
                        Else
                         
                        End If
                        '=== code de classement final
                        'if logall=1 then file02.WriteLine "value before: " & data01 & " After: " & val01 & " + " & asc01 & chr(9) & val01+asc01
                        If asc01 > 96 Then '=== uppercase A
                            asc01 = asc01 - 96
                        ElseIf asc01 > 64 Then '=== lowercase a
                            asc01 = asc01 - 64
                        End If
                     
                        ara01(x03, linecount) = val01 '=== new ordering integer for this column
                     
                        '=== create a new column to class by letter after this one
                        ara01(x03 + 1, linecount) = asc01
                     
                    End If
                Next
                If alpha01 = 0 Then
                    '=== remove the 0 before
                    ara01(x03, linecount) = CInt(data01)
                    ara01(x03 + 1, linecount) = 0
                End If
            ElseIf len01 > 0 Then
                '=== only 1 digit, so we assume it's a number (just to be faster)
                ara01(x03, linecount) = data01 '=== new ordering integer for this column
             
                '=== column to class by letter after this one (1 digit = no letter = 0)
                ara01(x03 + 1, linecount) = 0
            Else
                '=== len is 0, we do nothing
                ara01(x03, linecount) = 0
                ara01(x03 + 1, linecount) = 0
            End If
            splitcount = splitcount + 1
            '=== results, all numerics
            If htmlout = 1 Then file03.WriteLine "<td>" & ara01(x03, linecount) & "</td><td>" & ara01(x03 + 1, linecount) & "</td>"
         
        Next
     
        '=== tricky part, doing a supertotal to sort only one number for all six fields/columns
        supertotal = 0
        mul01 = 5
        super02 = ""
        For x03 = 0 To 5
            '=== do a super total for this line and the next for comparaison
            super01 = (ara01(x03, linecount) + 1) * (1000 ^ (mul01 + 1))
            supertotal = supertotal + super01
            mul01 = mul01 - 1
         
            '==== alphanumeric supertotal add 0 in front pf every digit, not working with dataset.sort either
            'super02 = super02 & left("00000", 5-len((ara01(x03,linecount)+1))) & ara01(x03,linecount)+1
         
        Next
        'dataset01.fields("supertotal DS").value = super02
     
        ara01(6, linecount) = supertotal
        'dataset01.fields("supertotal DS").value = supertotal
     
        If htmlout = 1 Then file03.WriteLine "<td>" & ara01(6, linecount) & "</td>"
     
        linecount = linecount + 1
        If htmlout = 1 Then file03.WriteLine "</tr>"
        dataset01.movenext
     
        '=== all supertotal must be computed before we can sort
        '=== so this loop was to split numbers, letters and compute a supertotal with multiplicated by 1000^positioninfieldvalue(0-5) values
    Loop
 
    If htmlout = 1 Then file03.WriteLine "</table>"
 
    '=== sorting loop, using supertotal
    '=== we move through dataset at the same time we move in the array that contain supertotal at position 6
 
    If logall = 1 Then file02.WriteLine Date & " " & Time & " START bubble sort with supertotal"
 
    '=== using SORT command from dataset would have been easy now, but noooo, error argument, number to weird
    '=== even if this a string, it cannot sort with dateset.sort command
    'dataset01.Sort = "supertotal DS"
 
    dataset01.movefirst
    'set row = CreateObject("ADODB.Recordsetrow")
 
    '=== exchange lines in dataset, is that possible?
    'dataset01.rows(1) = dataset01.rows(0)
    'http://www.w3schools.com/asp/ado_ref_recordset.asp
 
    ''''''''''''''''''''''''''''''''''''''''''
    '    bubble sort
    ''''''''''''''''''''''''''''''''''''''''''
    Dim supertotal01(1)
    ReDim ara01tempo(linecount - 1)
    If logall = 1 Then file02.WriteLine Date & " " & Time & " Bubble order START"
    '=== classement bulle, ligne par ligne, 6 fois
 
    For bubble01 = linecount - 2 To 0 Step -1
        For y03 = 0 To bubble01 '=== magica loop, row
         
            '=== if supertotal after is smaller, we exchange them
         
            If ara01(6, y03 + 1) < ara01(6, y03) Then
                For x04 = 0 To fieldscount01 - 1
                    '=== save actual matrix x elements
                    ara01tempo(x04) = ara02(x04, y03)
                    ara02(x04, y03) = ara02(x04, y03 + 1) '=== go up one row in matrix
                    ara02(x04, y03 + 1) = ara01tempo(x04)
                Next
                '=== exchange supertotal also
                supertotaltemp = ara01(6, y03)
                ara01(6, y03) = ara01(6, y03 + 1)
                ara01(6, y03 + 1) = supertotaltemp
             
            End If
        Next
    Next
 
    If logall = 1 Then file02.WriteLine Date & " " & Time & " END bubble sort"
 
    '=== final result
    If htmlout = 1 Then file03.WriteLine "<br>TABLE 03 sorted after all was converted to number to make a supertotal"
    If htmlout = 1 Then file03.WriteLine "<br><table width=""70%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"
 
    '=== fields names as columns titles of the table
    If htmlout = 1 Then file03.WriteLine "<tr>"
    For i = 0 To fieldscount01 - 1
        If htmlout = 1 Then file03.WriteLine "<td>" & dataset01.Fields(i).Name & "</td>"
    Next
    If htmlout = 1 Then file03.WriteLine "<td>Supertotal verification (not in DS)</td>"
    If htmlout = 1 Then file03.WriteLine "</tr>"
 
    For y = 0 To linecount - 1 '=== display results after bubble sort
        If htmlout = 1 Then file03.WriteLine "<tr>"
        For x = 0 To fieldscount01 - 1
            If htmlout = 1 Then file03.WriteLine "<td>" & ara02(x, y) & "</td>"
        Next
     
        If htmlout = 1 Then file03.WriteLine "<td>" & ara01(6, y) & "</td>"
        If htmlout = 1 Then file03.WriteLine "</tr>"
     
    Next
 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '   table03 sorted with 6 columns (split of the first column) and super total
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    array01 = ara02
 
    If htmlout = 1 Then file03.WriteLine "</table>"
 
    '=== delete old table01 if it exist
    tablename01 = "table03"
    On Error Resume Next
    err01 = 0: err02 = ""
    Sheet01.ListObjects(tablename01).Delete
    err01 = Err
    err02 = Err.Description
    On Error GoTo 0
 
    x = 1: y = (4 + rowcount01) * 2
 
    '=== columns names
    For i = 0 To fieldscount01 - 1
        Cells(y, x + i).Value = dataset01.Fields(i).Name
    Next
 
    '=== range01 include column title
    Set Range01 = Range(Cells(y, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
    '=== range02 is data only
    Set Range02 = Range(Cells(y + 1, x), Cells(y + 1 + rowcount01, x + fieldscount01 - 1))
    Range02.Value = Application.WorksheetFunction.Transpose(array01)
     
    Sheet01.ListObjects.Add(xlSrcRange, Range01, , xlYes).Name = tablename01
 
 
    If logall = 1 Then file02.WriteLine ""
    If logall = 1 Then file02.WriteLine Date & " " & Time & " END"
 
 
 
Else
    '=== error array have onle one dimension
    MsgBox ("ERROR array only have one dimension" & vbCrLf & "the dataset must have more than one line of data" & vbCrLf & "meaning, 2 dimensions")
End If

If logall = 1 Then file02.Close
If htmlout = 1 Then file03.Close


End Sub