VBA Tipp: Römische Zahlen

Aufgabenstellung

Ich möchte eine ganze Zahl in der römischen Schreibweise darstellen.

Lösung

Public Function Roman(Arg)
   Dim Res As String
   Dim Tmp As Long
 
   Roman = Null
   If Not IsNull(Arg) Then
      If Arg < 4000 Then
         Tmp = Val(Arg)
         Res = Res & RomanLetter(Tmp, "M", " ", " ", 1000)
         Res = Res & RomanLetter(Tmp, "C", "D", "M", 100)
         Res = Res & RomanLetter(Tmp, "X", "L", "C", 10)
         Res = Res & RomanLetter(Tmp, "I", "V", "X", 1)
         Roman = Res
      End If
   End If
End Function
 
Private Function RomanLetter(Arg, L1 As String, L2 As String, _
                             L3 As String, v As Integer)
 
   Dim Res As String
 
   If Arg >= 9 * v Then
      Res = Res & L1 & L3
      Arg = Arg - 9 * v
   End If
   If Arg >= 5 * v Then
      Res = Res & L2
      Do While Arg >= 6 * v
         Res = Res & L1
         Arg = Arg - 1 * v
      Loop
      Arg = Arg - 5 * v
   End If
   If Arg >= 4 * v Then
      Res = Res & L1 & L2
      Arg = Arg - 4 * v
   End If
   Do While Arg >= 1 * v
      Res = Res & L1
      Arg = Arg - 1 * v
   Loop
   RomanLetter = Res
End Function

Die folgende Lösung stammt von Bernhard Froschauer:

Public Function fktRoman(ByVal Arab As Long) As String
   Dim Arabisch As Variant
   Dim Roemisch As Variant
   Dim Roem     As String
   Dim i        As Long
 
   Arabisch = Array(1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000)
   Roemisch = Array("I", "IV", "V", "IX", "X", "XL", "L", "XC", _
                    "C", "CD", "D", "CM", "M")
 
   For i = UBound(Arabisch) To LBound(Arabisch) Step -1
      Do While Arab >= Arabisch(i)
         Arab = Arab - Arabisch(i)
         Roem = Roem + Roemisch(i)
      Loop
   Next
   fktRoman = Roem
End Function

Aufruf

   Debug.Print Roman(123)     '==> CXXIII
 
   'bzw.:
 
   Debug.Print fktRoman(123)  '==> CXXIII