VBA Tipp: Römische Zahlen
Aus DBWiki
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