Option Explicit
Sub test()
SortRoman Range("MyRange")
End Sub
Sub SortRoman(UserRange As Range, Optional ColumnNumber As Integer = 1)[green]
' Assumes the user range includes a row of column headers[/green]
Dim SortRange As Range
Dim nRow As Long
Application.ScreenUpdating = False[green]
' Insert sort work column in front of UserRange[/green]
UserRange.Columns(1).Insert Shift:=xlToRight[green]
' Set sort range to include the work column[/green]
Set SortRange = Union(UserRange, UserRange.Columns(1).Offset(0, -1))
With SortRange[green]
' Populate the work column from the column to sort on[/green]
UserRange.Columns(ColumnNumber).Copy .Columns(1)[green]
' Convert internal Roman Numerals to Arabic[/green]
For nRow = 2 To SortRange.Rows.Count
.Cells(nRow, 1) = ConvertInternalRomanNumerals(.Cells(nRow, 1))
Next nRow[green]
' Sort the working range[/green]
.Sort Key1:=SortRange.Columns(1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom[green]
' Delete the working column[/green]
.Columns(1).Delete Shift:=xlToLeft
End With
Application.ScreenUpdating = True
End Sub
Function ConvertInternalRomanNumerals(Text As String) As String[green]
' Scans the text to find an imbedded Roman numeral and converts it to Arabic
' Limitation: Only Roman numerals I to XX (1 ro 20) may be used
' Algorithm:
' 1. Scan from left to right for first instance of "-"
' 2. If "-" is found then
' 3. Scan for the first instance of "i", "v" or "x" (first char of RN)
' 4. Scan for the first instance of something not "i" "v" or "x" (last char of RN)
' 5. Convert the RN to a 2-digit number and substitute.[/green]
Dim sWork As String
Dim sTest As String
Dim sRomanNumber As String
Dim sArabicNumber As String
Dim nHyphen As Integer
Dim nI As Integer
Dim nV As Integer
Dim nX As Integer
Dim nStart As Integer
Dim nLength As Integer[green]
' Default to self[/green]
sWork = Text
[green]
' Find hyphen[/green]
nHyphen = InStr(Text, "-")
If nHyphen > 0 Then
[green]
' Find first Roman Numeral character[/green]
nI = InStr(nHyphen, Text, "i", vbTextCompare)
nV = InStr(nHyphen, Text, "v", vbTextCompare)
nX = InStr(nHyphen, Text, "x", vbTextCompare)
nStart = LeastNonZero(nI, nV, nX)
If nStart > 0 Then
[green]
' Find last Roman Numeral character[/green]
nLength = 1
sTest = UCase(Mid(Text, nStart + nLength, 1))
While InStr("IVX", sTest) > 0
nLength = nLength + 1
sTest = UCase(Mid(Text, nStart + nLength, 1))
Wend
[green]
' Extract Roman Numeral and convert to 2-character Arabic[/green]
sRomanNumber = Mid(Text, nStart, nLength)
sArabicNumber = Right(100 + RomanToArabic(sRomanNumber), 2)
[green]
' Plug back into Text[/green]
sWork = Left(Text, nStart - 1) + sArabicNumber + Mid(Text, nStart + nLength + 1, 999)
End If
End If[green]
' Return resulting string[/green]
ConvertInternalRomanNumerals = sWork
End Function
Function LeastNonZero(ParamArray Values())
Dim i As Integer
LeastNonZero = 0
For i = LBound(Values) To UBound(Values)
If Values(i) > 0 Then
If (Values(i) < LeastNonZero) Or (LeastNonZero = 0) Then
LeastNonZero = Values(i)
End If
End If
Next i
End Function
Function RomanToArabic(ARomanNumber As String) As Integer[green]
' Quick and dirty conversion of the first 20 Roman numbers to Arabic
' Handles I thru XX only[/green]
Const ROMAN_NUMBERS = ".I.....II....III...IV....V.....VI....VII...VIII..IX....X.....XI....XII...XIII..XIV...XV....XVI...XVII..XVIII.XIX...XX...."
Dim nOffset As Integer
nOffset = InStr(1, ROMAN_NUMBERS, "." + ARomanNumber + ".", vbTextCompare)
RomanToArabic = (nOffset - 1) \ 6 + 1
End Function
