Sub Expansion_Click()
Dim strfill, word, worda, wordb, numbera, numberb, last, temp As String
Dim strarray() As String
Dim comstring() As String
Dim strexp, i, j As Long
Dim rng, cell As Range
Set rng = Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp))
For Each cell In rng
'STAGE1: Prepare string for splitting
'Replace all single/multiple spaces with "_":
For i = 1 To Len(cell.Value2)
If Mid(cell.Value2, i, 1) Like "[ ]" Then
If Mid(cell.Value2, i, 1) <> Mid(cell.Value2, i + 1, 1) Then
temp = temp & "_"
End If
Else
temp = temp & Mid(cell.Value2, i, 1)
End If
Next i
'Generate 'to' operator: "-"
temp = Replace(Replace(Replace(temp, "_-_", "-"), "_-", "-"), "-_", "-")
'Generate 'split' operator: "@"
temp = Replace(Replace(Replace(Replace(Replace(temp, "_,_", "@"), "_,", "@"), ",_", "@"), ",", "@"), "_", "@")
'STAGE2: Split final-formatted string
comstring = Split(temp, "@")
'Reset temp
temp = vbNullString
'Loop through all splits and process them
For j = LBound(comstring) To UBound(comstring)
'If not empty for robustness(, although shouldn't generate empty arrays)
If Not comstring(j) = vbNullString Then
'STAGE3: Split into word-prefix, numbera, and numberb
'Step one: split by "-"
strarray = Split(comstring(j), "-")
'Remove word at end
For i = Len(strarray(LBound(strarray))) To 1 Step -1
If Mid(strarray(LBound(strarray)), i, 1) Like "[0123456789]" Then
'Error Handling
Exit For
Else
last = Mid(strarray(LBound(strarray)), i, 1) & last
strarray(LBound(strarray)) = Mid(strarray(LBound(strarray)), 1, i - 1)
End If
Next i
If Not strarray(LBound(strarray)) = vbNullString Then
'Step two: extract numbers from first split
i = Len(strarray(LBound(strarray)))
Do While Mid(strarray(LBound(strarray)), i, 1) Like "[0123456789]"
numbera = numbera & Mid(strarray(LBound(strarray)), i, 1)
i = i - 1
'Error handling
If i = 0 Then Exit Do
Loop
' Fix the inversion
numbera = StrReverse(numbera)
worda = Mid(strarray(LBound(strarray)), 1, i)
'Step three: fix to keep the "0"s
i = 1
Do While Mid(numbera, i, 1) Like "[0]"
numbera = Mid(numbera, i + 1, Len(numbera))
worda = worda & "0"
Loop
' Finally fill with number
strarray(LBound(strarray)) = numbera * 1
End If
'''''''''''''''''''''''''''''''''''''''''
If UBound(strarray) > 0 Then
'Remove word at end
For i = Len(strarray(UBound(strarray))) To 1 Step -1
If Mid(strarray(UBound(strarray)), i, 1) Like "[0123456789]" Then
'Error Handling
Exit For
Else
'Only take one non-number ending
If last = vbNullString Then
last = Mid(strarray(UBound(strarray)), i, 1) & last
End If
strarray(UBound(strarray)) = Mid(strarray(UBound(strarray)), 1, i - 1)
End If
Next i
If Not strarray(UBound(strarray)) = vbNullString Then
'Step four: extract numbers from first split
i = Len(strarray(UBound(strarray)))
Do While Mid(strarray(UBound(strarray)), i, 1) Like "[0123456789]"
numberb = numberb & Mid(strarray(UBound(strarray)), i, 1)
i = i - 1
'Error handling
If i = 0 Then Exit Do
Loop
' Fix the inversion
numberb = StrReverse(numberb)
wordb = Mid(strarray(UBound(strarray)), 1, i)
'Step five: fix to keep the "0"s
i = 1
Do While Mid(numberb, i, 1) Like "[0]"
numberb = Mid(numberb, i + 1, Len(numberb))
wordb = wordb & "0"
Loop
' Finally fill with number
strarray(UBound(strarray)) = numberb * 1
End If
End If
'Step six: use longer word for prefix
If Len(worda) > Len(wordb) Then
word = worda
Else
word = wordb
End If
'STAGE4: Generate list
'''''''''''''''''''''''
'If we have two entries i.e. a range
If UBound(strarray) > 0 Then
'Set first output to first entry
strexp = strarray(LBound(strarray))
If strfill = vbNullString Then
strfill = word & strexp & last
Else
strfill = strfill + ", " & word & strexp & last
End If
'Iterate and add to fill string until equal to last entry
Do Until strexp = strarray(UBound(strarray))
'Forward or backwards depends on whether second entry bigger or smaller
If (strarray(UBound(strarray)) * 1) > (strarray(LBound(strarray)) * 1) Then
strexp = strexp + 1
Else
strexp = strexp - 1
End If
strfill = strfill & ", " & word & strexp & last
Loop
'If only single entry
Else
If j > 0 Then
strfill = strfill & ", " & word & Trim(strarray(0)) & last
Else
strfill = word & comstring(0) & last
End If
End If
'reset the temp strings
word = vbNullString
worda = vbNullString
wordb = vbNullString
numbera = vbNullString
numberb = vbNullString
last = vbNullString
'''''''''''''''''''''''''
'STAGE5: Fill with result
End If
Next j
'Fill cell next with expanded series
cell.Offset(, 1) = strfill
'Reset fill string
strfill = vbNullString
Next cell
End Sub