Roman and Arabic Numbers Conversions
There were many people (including in these forums) provided many different ways to convert back and fort between Roman and Arabic numbers.
Here is my version if you want it short: (Don't complain, I am lazy to write full comments)
Code:
Function RomanToArabic(ByVal Roman As String) As Integer
'-- Convert Roman number to Arabic number
'-- Return -32768 as an error flag if Roman string is invalid
Dim i As Integer
Dim Unit As Integer
Dim OldUnit As Integer
OldUnit = 1000
For i = 1 To Len(Roman)
Select Case UCase(Mid$(Roman, i, 1))
Case "I": Unit = 1
Case "V": Unit = 5
Case "X": Unit = 10
Case "L": Unit = 50
Case "C": Unit = 100
Case "D": Unit = 500
Case "M": Unit = 1000
Case Else: '-- unaccepted Roman digit
RomanToArabic = -32768
Exit Function
End Select
If Unit > OldUnit Then RomanToArabic = RomanToArabic - 2 * OldUnit
RomanToArabic = RomanToArabic + Unit
OldUnit = Unit
Next i
End Function
Code:
Function ArabicToRoman(ByVal Arabic As Integer) As String
'-- Convert Arabic number to Roman nunber
Const R100 = ",C,CC,CCC,CD,D,DC,DCC,DCCC,CM"
Const R10 = ",X,XX,XXX,XL,L,LX,LXX,LXXX,XC"
Const R1 = ",I,II,III,IV,V,VI,VII,VIII,IX"
If Arabic < 0 Then '-- this is not a proper way but
ArabicToRoman = "-" ' provides a way to deal with
Arabic = -Arabic ' negative numbers instead of
End If ' raising an error
ArabicToRoman = ArabicToRoman & String$(Arabic \ 1000, "M")
Arabic = Arabic Mod 1000
ArabicToRoman = ArabicToRoman & Split(R100, ",")(Arabic \ 100)
Arabic = Arabic Mod 100
ArabicToRoman = ArabicToRoman & Split(R10, ",")(Arabic \ 10)
Arabic = Arabic Mod 10
ArabicToRoman = ArabicToRoman & Split(R1, ",")(Arabic)
End Function
Re: Roman and Arabic Numbers Conversions
Re: Roman and Arabic Numbers Conversions
Here's my fairly optimized version:
Code:
Function RomanToArabic(RomanStr As String) As Long
'
'If a valid roman numeral string is specified, returns the equivalent arabic number value, otherwise returns
'an error value of -1. Handles both upper-case and lower-case roman numerals.
'
'NOTE: This algorithm assumes that the specified roman numeral string is a valid, left to right descending
'sequence. Nonsensical roman numeral-like strings will generally produce nonsensical results.
'
'Author: Peter Straton
'
'*************************************************************************************************************
Const DOT As Byte = 46
Const UC_I As Byte = 73, LC_i As Byte = 105
Const UC_V As Byte = 86, LC_v As Byte = 118
Const UC_X As Byte = 88, LC_x As Byte = 120
Const UC_L As Byte = 76, LC_l As Byte = 108
Const UC_C As Byte = 67, LC_c As Byte = 99
Const UC_D As Byte = 68, LC_d As Byte = 100
Const UC_M As Byte = 77, LC_m As Byte = 109
Dim i As Integer
Dim ByteVals() As Byte
Dim CharArabicVal As Integer
Dim PrevCharArabicVal As Integer
ByteVals = RomanStr 'Direct assignment of String to Byte array works
For i = LBound(ByteVals) To UBound(ByteVals) Step 2 'Skip each double-byte's upper byte
'Get the next roman character's arabic number value
Select Case ByteVals(i) 'For optimized execution, case sequence is in generally most-probable order
Case UC_I, LC_i: CharArabicVal = 1
Case UC_V, LC_v: CharArabicVal = 5
Case UC_X, LC_x: CharArabicVal = 10
Case UC_M, LC_m: CharArabicVal = 1000
Case UC_C, LC_c: CharArabicVal = 100
Case UC_L, LC_l: CharArabicVal = 50
Case UC_D, LC_d: CharArabicVal = 500
Case DOT: CharArabicVal = 0 'Ignore possible appended period character (e.g. outline syntax)
Case Else
RomanToArabic = -1 'Found an invalid roman character, return error condition
Exit Function
End Select
RomanToArabic = RomanToArabic + CharArabicVal 'Add in the new value
If CharArabicVal > PrevCharArabicVal Then
'The current character's Arabic value is greater than the previous character's value, so subtract
'out the previous character's value twice: once to remove its previously presumed, erroneous
'addition to the total and once to implement its subtractive notation, indicated by its position
'to the left of the current, greater-valued character .
RomanToArabic = RomanToArabic - 2 * PrevCharArabicVal
End If
PrevCharArabicVal = CharArabicVal
Next i
End Function