VBA Tipp: Römische Zahlen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

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

Lösung

Public Function Roman(Arg)
Dim Res As String, 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, Roemisch As Variant, _
  Roem As String, 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 I
  fktRoman = Roem
End Function

Aufruf

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