Word VBA Natural Sorting - vba

Question

I want to sort an array, or the Files from a Filesystemobject Folder, the way we'd expect them to be if sorted by a human. What I ultimately am trying to accomplish is a macro that takes images from a folder and inserts them into the word document with text above each one to identify what it represents, here I use steps for a guide and it's crucial that Step 2 come before step 100;
Setting up my test sub;
Sub RunTheSortMacro()
Dim i As Long
Dim myArray As Variant
'Set the array
myArray = Array("Step-1", "Step-2", "Step-10", "Step-15", "Step-9", "Step-20", "Step-100", "Step-8", "Step-7")
'myArray variable set to the result of SortArray function
myArray = SortArray(myArray)
'Output the Array through a message box
For i = LBound(myArray) To UBound(myArray)
MsgBox myArray(i)
Next i
End Sub
Then the only/best sort function I found is really only good for numbers;
Function SortArray(ArrayIn As Variant)
Dim i As Long
Dim j As Long
Dim Temp
'Sort the Array A-Z
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i) > ArrayIn(j) Then
SrtTemp = ArrayIn(j)
ArrayIn(j) = ArrayIn(i)
ArrayIn(i) = SrtTemp
End If
Next j
Next i
SortArray = ArrayIn
End Function
That function returns the array as;
Step-1,
Step-10,
Step-100,
Step-15,
Step-2,
Step-20,
Step-7,
Step-8,
Step-9
but I want;
Step-1,
Step-2,
Step-7,
Step-8,
Step-9,
Step-10,
Step-15,
Step-20,
Step-100
I thought using StrComp(ArrayIn(i), ArrayIn(j), vbBinaryCompare/vbTextCompare) would be one way to go but they seem to sort the same way. If it's easier, I am only going the array route because I couldn't find a way to sort the input files from;
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set Folder = objFSO.GetFolder(FolderPath)
For Each image In Folder.Files
ImagePath = image.Path
Selection.TypeText Text:=Left(image.Name, Len(image.Name) - 4)
Selection.TypeText Text:=vbCr
'Insert the images into the word document
Application.Selection.EndKey END_OF_STORY, MOVE_SELECTION
Application.Selection.InlineShapes.AddPicture (ImagePath)
Application.Selection.InsertBreak 'Insert a pagebreak
Next
So I was going to break the file name and path into two arrays that I could sort naturally;
Set objFiles = Folder.Files
FileCount = objFiles.Count
ReDim imageNameArray(FileCount)
ReDim imagePathArray(FileCount)
icounter = 0
For Each image In Folder.Files
imageNameArray(icounter) = (image.Name)
imagePathArray(icounter) = (image.Path)
icounter = icounter + 1
Next
but I can't find any reference to natural sorting in VBA.
Update, Additional Details;
I didn't think about the A and B after numbers and everything I search agrees on what "natural sorting" is; 1,2,3,A,B,C; Apple < 1A < 1C < 2. Regex might be good
This was how I achieved this in a python script;
import os
import re
def tryint(s):
try:
return int(s)
except:
return s
def alphanum_key(s):
""" Turn a string into a list of string and number chunks.
"z23a" -> ["z", 23, "a"]
"""
return [ tryint(c) for c in re.split('([0-9]+)', s) ]
def sort_nicely(l):
""" Sort the given list in the way that humans expect.
"""
l.sort(key=alphanum_key)
files = [file for file in os.listdir(".") if (file.lower().endswith('.png')) or (file.lower().endswith('.jpg'))]
files.sort(key=alphanum_key)
for file in sorted(files,key=alphanum_key):
stepname = file.strip('.jpg')
print(stepname.strip('.png')
For VBA I have found that these;
Function SortArray(ArrayIn As Variant)
Dim i As Long
Dim j As Long
Dim Temp1 As String
Dim Temp2 As String
Dim Temp3 As String
Dim Temp4 As String
'Sort the Array A-Z
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
Temp1 = ArrayIn(i)
Temp2 = ArrayIn(j)
Temp3 = onlyDigits(Temp1)
Temp4 = onlyDigits(Temp2)
If Val(Temp3) > Val(Temp4) Then
ArrayIn(j) = Temp1
ArrayIn(i) = Temp2
End If
Next j
Next i
SortArray = ArrayIn
End Function
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Give me the numerical sort but not the alphabetical, so 1B is sorting before 1A.

Answer 1

Here's the solution to sort Naturally in VBA
Setup/Testing
Sub RunTheSortMacro()
Dim i As Long
Dim myArray As Variant
'Set the array
myArray = Array("Step 15B.png", "Cat 3.png", "Step 1.png", "Step 2.png", "Step 15C.png", "Dog 1.png", "Step 10.png", "Step 15A.png", "Step 9.png", "Step 20.png", "Step 100.png", "Step 8.png", "Step 7Beta.png", "Step 7Alpha.png")
'myArray variable set to the result of SortArray function
myArray = SortArray(myArray)
For i = LBound(myArray) To UBound(myArray)
Debug.Print myArray(i)
Next
End Sub
This is the only function needed to be called in the main part;
Function SortArray(ArrayIn As Variant)
Dim i As Long
Dim j As Long
Dim Temp1 As String
Dim Temp2 As String
Dim myRegExp, myRegExp2, Temp3, Temp4, Temp5, Temp6, regExp1_Matches, regExp2_Matches
'Number and what's after the number
Set myRegExp = CreateObject("vbscript.regexp")
myRegExp.IgnoreCase = True
myRegExp.Global = True
myRegExp.pattern = "[0-9][A-Z]"
'Text up to a number or special character
Set myRegExp2 = CreateObject("vbscript.regexp")
myRegExp2.IgnoreCase = True
myRegExp2.Global = True
myRegExp2.pattern = "^[A-Z]+"
'Sort by Fisrt Text and number
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
Temp1 = ArrayIn(i)
Temp2 = ArrayIn(j)
Temp3 = onlyDigits(Temp1)
Temp4 = onlyDigits(Temp2)
Set regExp1_Matches = myRegExp2.Execute(Temp1)
Set regExp2_Matches = myRegExp2.Execute(Temp2)
If regExp1_Matches.Count = 1 And regExp2_Matches.Count = 1 Then 'eliminates blank/empty strings
If regExp1_Matches(0) > regExp2_Matches(0) Then
ArrayIn(j) = Temp1
ArrayIn(i) = Temp2
ElseIf regExp1_Matches(0) = regExp2_Matches(0) Then
If Val(Temp3) > Val(Temp4) Then
ArrayIn(j) = Temp1
ArrayIn(i) = Temp2
End If
End If
End If
Next j
Next i
'Sort the array again by taking two at a time finds number followed by letters and sorts the two alphabetically, ex 1A, 1B
For i = LBound(ArrayIn) To (UBound(ArrayIn) - 1)
j = i + 1
Temp1 = ArrayIn(i)
Temp2 = ArrayIn(j)
Set regExp1_Matches = myRegExp.Execute(Temp1)
Set regExp2_Matches = myRegExp.Execute(Temp2)
If regExp1_Matches.Count = 1 And regExp2_Matches.Count = 1 Then
If regExp1_Matches(0) > regExp2_Matches(0) Then
ArrayIn(j) = Temp1
ArrayIn(i) = Temp2
End If
End If
Next i
SortArray = ArrayIn
End Function
Found this was useful for the numerical sorting;
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Results
Input:
Step 15B.png
Cat 3.png
Step 1.png
Step 2.png
Step 15C.png
Dog 1.png
Step 10.png
Step 15A.png
Step 9.png
Step 20.png
Step 100.png
Step 8.png
Step 7Beta.png
Step 7Alpha.png
Output:
Cat 3.png
Dog 1.png
Step 1.png
Step 2.png
Step 7Alpha.png
Step 7Beta.png
Step 8.png
Step 9.png
Step 10.png
Step 15A.png
Step 15B.png
Step 15C.png
Step 20.png
Step 100.png