AW: Römische Zahlen in Arabische umwandeln
20.09.2015 12:03:13
Sepp
Hallo Alifa,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub test()
Dim RN As String
RN = "MDCCCLXXXVII"
If IsRomanNumerial(RN) Then
MsgBox RomToArab(RN)
Else
MsgBox "Ungültige Eingabe!"
End If
End Sub
Private Function IsRomanNumerial(RomanNumerial As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("Vbscript.regexp")
With objRegExp
.IgnoreCase = True
.Global = True
.Pattern = "(([IXCM])\2{3,})|[^IVXLCDM]|([IL][LCDM])|([XD][DM])|(V[VXLCDM])|(IX[VXLC])|" & _
"(VI[VX])|(XC[LCDM])|(LX[LC])|((CM|DC)[DM])|(I[VX]I)|(X[CL]X)|(C[DM]C)|(I{2,}[VX])|" & _
"(X{2,}[CL])|(C{2,}[DM])"
If .test(RomanNumerial) = True Then GoTo ErrExit
End With
IsRomanNumerial = True
Exit Function
ErrExit:
IsRomanNumerial = False
End Function
Private Function RomToArab(r As String) As Integer
Dim p As Integer
Dim z As String
r = UCase(r)
If Len(r) = 1 Then '1. Basisklausel
Select Case r
Case "I"
RomToArab = 1
Case "V"
RomToArab = 5
Case "X"
RomToArab = 10
Case "L"
RomToArab = 50
Case "C"
RomToArab = 100
Case "D"
RomToArab = 500
Case "M"
RomToArab = 1000
End Select
ElseIf Len(r) = 0 Then '2. Basisklausel
RomToArab = 0
Else 'rekursive Klausel
search_max r, z, p
RomToArab = RomToArab(z) - _
RomToArab(Mid(r, 1, p - 1)) + _
RomToArab(Mid(r, p + 1, 1000))
End If
End Function
Private Sub search_max(r As String, z As String, p As Integer)
Dim i As Integer
Dim j As Integer
Const f = "MDCLXVI"
For i = 1 To Len(f)
For j = 1 To Len(r)
If Mid(r, j, 1) = Mid(f, i, 1) Then
p = j
z = Mid(f, i, 1)
Exit Sub
End If
Next j
Next i
End Sub
Gruß Sepp