' Überarbeitet von Rahan
' 15.12.2010
' 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)
 
        'Rahan
        '15.12.2010
        RN = RN + RZ(Beginn + 1)
      Case 5
        RN = RN + RZ(Beginn + 1)
      Case 6, 7, 8
        'Rahan
        '15.12.2010
        'alt RN = RN + RZ(Beginn + 2)
        RN = RN + RZ(Beginn + 1)
        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