Although this is similar to previous posts, it is different enough that
earlier solutions did not resolve my problem.
I am sorting a list of part numbers. They are in a three-part format --
prefix, base, suffix. The base is always numeric. The prefix and suffix are
alphabetic. A number may be comprised of one, two, or all three of the
sections. I want the numbers sorted by base first, then by prefix and then
by suffix. See a portion of my list below:
100MS
1577
200322
200861
200886S
202CCAG
40MPB
40MS
40MST
8984YY
90MS
AEL0801H
CDS211TTRW
DC216TTRB
DS206GG
P90R
PAWT214RA
PNR112R
WPS207GRC
WPSH115RRC
I want the 40xx numbers to come before 100MS and before 1157. Can this be
done in Excel 2003?
Thanks for any help you can give me.
The following should get you started.
It does not check for a valid part number configuration, but the routine will
crash if that happens, so you can work out how you want to handle it.
As written, it sorts a single column of values and writes those values, sorted
into a column starting with rDest (G1 in this example).
Note that the list is determined by expanding the Selected cell to the current
region, and then assuming that the first row is a label.
The part numbers are parsed into an array where the elements correspond to
prefix, base and suffix. The sort routine can sort on each element.
IT sorts your list:
40MPB
40MS
40MST
90MS
P90R
100MS
PNR112R
WPSH115RRC
202CCAG
DS206GG
WPS207GRC
CDS211TTRW
PAWT214RA
DC216TTRB
AEL801H
1577
8984YY
200322
200861
200886S
=====================================================
Option Explicit
Sub SortPNs()
Dim tPN As Variant
Dim PN()
Dim i As Long, j As Long
Dim rDest As Range
Set rDest = Range("G1")
Dim c As Range, rg As Range
'Expand to current region
Set rg = Selection.CurrentRegion
'Assume header row
Set rg = rg.Offset(1, 0).Resize(rg.Count - 1, 1)
ReDim PN(0 To rg.Count - 1, 0 To 2)
i = 0
For Each c In rg
tPN = ParsePN(c.Value)
PN(i, 0) = tPN(0) 'prefix
PN(i, 1) = Val(tPN(1)) 'number base; _
force to number for sort routine
PN(i, 2) = tPN(2) 'suffix
i = i + 1
Next c
'Sort from least to most significant
PN = BubbleSort(PN, 2) 'suffix
PN = BubbleSort(PN, 0) 'prefix
PN = BubbleSort(PN, 1) 'number base
rDest.EntireColumn.ClearContents
For i = 0 To UBound(PN)
rDest.Offset(i, 0).Value = _
PN(i, 0) & PN(i, 1) & PN(i, 2)
Next i
End Sub
'-------------------------------------------------------
Private Function ParsePN(str As String) As Variant
Dim re As RegExp
Dim mc As MatchCollection
Dim t(2)
Dim i As Long
Set re = New RegExp
With re
.Global = True
.Pattern = "^(\D*)(\d+)(\D*)$"
If .Test(str) = True Then
Set mc = .Execute(str)
For i = 0 To 2
t(i) = mc(0).SubMatches(i)
Next i
ParsePN = t
Else
ParsePN = "" 'will cause error in main section
End If
End With
End Function
'-----------------------------------------------------------
Private Function BubbleSort(TempArray As Variant, d As Long) _
'D is dimension to sort on
Dim temp() As Variant
Dim i As Integer, j As Integer, k As Integer
Dim NoExchanges As Boolean
k = UBound(TempArray, 2)
ReDim temp(0, k)
Do
NoExchanges = True
For i = 0 To UBound(TempArray) - 1
If TempArray(i, d) > TempArray(i + 1, d) Then
NoExchanges = False
For j = 0 To k
temp(0, j) = TempArray(i, j)
TempArray(i, j) = TempArray(i + 1, j)
TempArray(i + 1, j) = temp(0, j)
Next j
End If
Next i
Loop While Not NoExchanges
BubbleSort = TempArray
End Function
========================================
--ron