I am preparing a classic presentation of numbers.
I just need it for a catchy test.
Is there a macro or any formula to convert whole numbers into Romen
numerals ?
Here are two functions I've posted in the distant past (written for the
compiled version of VB, but which work fine in VBA), one for converting to
Roman Numbers and the other to convert from Roman Numbers...
Function ToRoman(ByVal Number As Long) As String
Dim X As Integer
Dim DigitIndex As Integer
Dim MaxNumeralCount As Integer
Dim Digits() As Byte
Dim Numerals() As Byte
Numerals = StrConv("IVXLCDM", vbFromUnicode)
MaxNumeralCount = Number \ 10 ^ (UBound(Numerals) \ 2)
Number = Number Mod 10 ^ (UBound(Numerals) \ 2)
ToRoman = String$(MaxNumeralCount, _
Numerals(UBound(Numerals)))
Digits = StrConv(CStr(Number), vbFromUnicode)
For X = 0 To UBound(Digits)
DigitIndex = 2 * (UBound(Digits) - X)
If Digits(X) = vbKey9 Then
ToRoman = ToRoman & Chr$(Numerals(DigitIndex)) & _
Chr$(Numerals(DigitIndex + 2))
ElseIf Digits(X) >= vbKey5 Then
ToRoman = ToRoman & Chr$(Numerals(DigitIndex + 1)) & _
String$(Digits(X) - vbKey0 - 5, _
Chr$(Numerals(DigitIndex)))
ElseIf Digits(X) = vbKey4 Then
ToRoman = ToRoman & Chr$(Numerals(DigitIndex)) & _
Chr$(Numerals(DigitIndex + 1))
Else
ToRoman = ToRoman & String$(Digits(X) - vbKey0, _
Chr$(Numerals(DigitIndex)))
End If
Next
End Function
Function FromRoman(ByVal RomanNumber As String) As Long
Dim DigitCount As Integer
Dim NumeralCount As Integer
Dim Answer() As Long
Dim Digits() As Byte
Dim RomanNumerals() As Byte
RomanNumerals = StrConv("IVXLCDM", vbFromUnicode)
Digits = StrConv(UCase$(RomanNumber), vbFromUnicode)
ReDim Answer(UBound(Digits))
For DigitCount = UBound(Digits) To 0 Step -1
For NumeralCount = 0 To UBound(RomanNumerals)
If Digits(DigitCount) = RomanNumerals(NumeralCount) Then
If NumeralCount Mod 2 Then
Answer(DigitCount) = 5 * 10 ^ ((NumeralCount - 1) / 2)
Else
Answer(DigitCount) = 10 ^ (NumeralCount / 2)
End If
Exit For
End If
Next
Next
For DigitCount = UBound(Answer) To 0 Step -1
If DigitCount < UBound(Answer) Then
If Answer(DigitCount) < Answer(DigitCount + 1) Then
Answer(DigitCount) = -Answer(DigitCount)
End If
End If
FromRoman = FromRoman + Answer(DigitCount)
Next
End Function
