George,
'--------------------------------------------
Sub HelperColumnsForSorting()
' Jim Cone - San Francisco, USA - May 07, 2005
' This program provides additional data columns that can be used
' to sort. After the sort the added columns should be deleted.
' To use - select the column you want to sort and run this code.
' Note: No sorting is done by the program.
' The columns added to the right of the first selected column are:
' "Length", "Prefix", "Padded #", "Suffix", "Combined", "Reversed"
' For the "Padded #" column, the program pulls the last (right most)
' group of contiguous numbers from each cell.
' It pads the group with enough leading zeros so as to equal the
' length of the longest group in the entire selection.
' This allows the selection to be sorted in strict numerical order.
' Data added to the other columns should be self explanatory.
On Error GoTo NoHelp_ErrorHandler
Dim rngToSort As Excel.Range
Dim rngCell As Excel.Range
Dim lngN As Long
Dim lngMax As Long
Dim lngCum As Long
Dim lngEnd As Long
Dim lngCount As Long
Dim lngStart As Long
Dim lngLength As Long
Dim strEntry As String
Dim strNumbers As String
Dim strArray() As String
Dim blnNumbers As Boolean
Set rngToSort = Selection.Columns(1).Cells
If rngToSort.Count = Rows.Count Then
MsgBox "Do not Select an entire column. ", vbInformation, _
" Helper Columns for Sorting - by Jim Cone"
Exit Sub
ElseIf WorksheetFunction.CountA(rngToSort) = 0 Then
MsgBox "There is no data in the selection. ", vbInformation, _
" Helper Columns for Sorting - by Jim Cone"
Exit Sub
End If
Application.ScreenUpdating = False
Application.StatusBar = "WORKING..."
ReDim strArray(1 To rngToSort.Count, 1 To 6)
'Insert six columns to the right and add column titles.
With Range(rngToSort.Offset(0, 1), rngToSort.Offset(0, 6))
.EntireColumn.Insert shift:=xlToRight
End With
If rngToSort.Row > 1 Then
With rngToSort.Offset(-1, 1)(1).Resize(1, 6)
.Value = Array("Length", "Prefix", "Padded #", _
"Suffix", "Combined", "Reversed")
.Font.Bold = True
End With
End If
lngCount = 1
'Examine each cell in the selection
For Each rngCell In rngToSort
lngEnd = 0
lngMax = 0
lngStart = 0
blnNumbers = False
'Add length of text to the array.
lngLength = Len(rngCell.Text)
If lngLength Then strArray(lngCount, 1) = lngLength
strEntry = Chr$(32) & rngCell.Text
lngLength = Len(strEntry)
'Get position of last number in each cell.
For lngN = lngLength To 1 Step -1
If Mid$(strEntry, lngN, 1) Like "#" Then
lngEnd = lngN
blnNumbers = True
'Save text after the numbers (Suffix).
strArray(lngCount, 4) = Right$(strEntry, lngLength - lngEnd)
lngLength = lngN
Exit For
End If
Next
'Get position of first number in last numeric group in each cell.
If blnNumbers Then
For lngN = lngLength To 1 Step -1
If Not Mid$(strEntry, lngN, 1) Like "#" Then
lngStart = lngN
'Save text before the numbers (Prefix).
strArray(lngCount, 2) = Trim$(Left$(strEntry, lngStart))
Exit For
End If
Next 'lngN
End If
lngMax = lngEnd - lngStart
If lngMax > lngCum Then lngCum = lngMax
'Save the numbers.
strArray(lngCount, 3) = Mid$(strEntry, lngStart + 1, lngMax)
lngCount = lngCount + 1
Next 'rngCell
'Pad numbers with zeros.
For lngN = 1 To UBound(strArray, 1)
strNumbers = strArray(lngN, 3)
lngLength = Len(strNumbers)
If lngLength > 0 Then
If lngCum > lngLength Then
strNumbers = String(lngCum - lngLength, "0") & strNumbers
End If
strArray(lngN, 3) = strNumbers
strArray(lngN, 5) = strArray(lngN, 2) & strArray(lngN, 3) & _
strArray(lngN, 4)
Else
With rngToSort(lngN)
If Len(.Text) > 0 Then
strArray(lngN, 3) = String(lngCum, "0")
strArray(lngN, 5) = rngToSort(lngN).Text
End If
End With
End If
'Reverse text.
strEntry = strArray(lngN, 5)
For lngEnd = Len(strEntry) To 1 Step -1
strArray(lngN, 6) = strArray(lngN, 6) & _
Mid$(strEntry, lngEnd, 1)
Next 'lngEnd
Next 'rngCell
'Put data in the new columns.
With Range(rngToSort.Offset(0, 1), rngToSort.Offset(0, 6))
.Value = strArray()
.EntireColumn.AutoFit
End With
'Convert numbers as text to numbers.
With rngToSort.Offset(0, 1)
.NumberFormat = "0_)"
.Value = .Value
End With
AlmostDone:
On Error Resume Next
Set rngCell = Nothing
Set rngToSort = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
NoHelp_ErrorHandler:
Beep
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "Error " & Err.Number & " - " & Err.Description, _
vbCritical, " Helper Columns for Sorting - by Jim Cone"
Resume AlmostDone
End Sub
'------------------------------------
message I have a spreadsheet I would like to sort by IP address. I have a format
192.168.2.1 but excel recognizes the next address as 192.168.2.10 then
192.168.2.100. I do not have leading zeros so I have been unsuccessfull
parsing the data using LEFT and RIGHT functions and sorting that way. Can I
divide the data by "."? is that necessary to accomplish the proper sort?
TIA
George
