Rubrik: Variablen/Strings · Algorithmen/Mathematik | VB-Versionen: VB6, VBA | 20.09.10 |
Arabische in römische Nummern umwandeln Diese Funktion wandelt arabische Zahlen in römische Nummern um. | ||
Autor: Tobias König | Bewertung: | Views: 13.403 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Mit nachfolgender Funktion lassen sich arabische Zahlen in römische Darstellung umwandeln.
' Design by Tobias König, Dresden ' Bei Gross = False wird die Römische Ziffer komplett klein geschrieben Function RömischeNummerErmitteln(ByVal Nummer As Integer, _ Optional ByVal Gross As Boolean = True) As String If Nummer = 0 Then Exit Function Dim j As Byte, k As Byte, d As Byte Dim Pa As String, RN As String Dim RZ As Variant Dim Beginn As Long ' vierstellige Zahl erstellen Dim Digit(4) As Integer Pa = Format(Nummer, "0000") For j = 1 To 4 Digit(j) = Mid(Pa, j, 1) Next Select Case Digit(1) Case Is <> 0 For k = 1 To Digit(1) RN = RN + "M" Next k End Select RZ = Array("M", "D", "C", "L", "X", "V", "I") For d = 2 To 4 Beginn = d * 2 - 4 Select Case Digit(d) Case 1, 2, 3 For k = 1 To Digit(d) RN = RN + RZ(Beginn + 2) Next k Case 4 RN = RN + RZ(Beginn + 2) Case 5 RN = RN + RZ(Beginn + 1) Case 6, 7, 8 RN = RN + RZ(Beginn + 2) For k = 1 To Digit(d) - 5 RN = RN + RZ(Beginn + 2) Next k Case 9 RN = RN + RZ(Beginn + 2) + RZ(Beginn) End Select Next d If Not Gross Then RN = LCase$(RN) RömischeNummerErmitteln = RN End Function
Anmerkung:
Die Idee zu dieser Funktion stammt eigentlich von Rene Probst und seiner WordFaq. Diese habe ich jedoch verbessert durch die d-Schleife.