[VB/VBA] Conversion nombre Romain -> Arabe

Ces fonctions permettent de convertir des nombres romain exprimer en "lettres" du type MCMLXIX en nombre au format arabe soit 1969.

Ces procédures sont disponnible en fonction personnalisée pour Excel et en VBA pour un Userform.
Le code VBA est compatible avec VB6.

FONCTION PERSONNALISÉE POUR EXCEL

Coller le code ci-dessous dans un module général, Module1 par exemple.

Dim Rm As String

Public Function RomainArabe(C As Range) As Integer
Dim TB
Dim Arab As Integer
Dim i As Byte, A As Integer, Utb As Integer
    If C = "" Then RomainArabe = 0: Exit Function
ReDim TB(0)
    Application.Volatile
    i = 1: Utb = 1: Arab = 0
    Rm = Replace(C, " ", "") 'supprime les espaces éventuels
    Rm = UCase(Rm) ' met en majuscule si nécessaire
    While i <= Len(Rm)
        'traite les lettres une a une
        ReDim Preserve TB(Utb)
        A = NBlettre(i)
        TB(Utb) = A * ValeurLettre(Mid(Rm, i, 1))
        Debug.Print TB(Utb)
        i = i + A
        Utb = Utb + 1
    Wend
    ReDim Preserve TB(Utb): i = 1
    While i < UBound(TB)
        If TB(i) < TB(i + 1) Then
             Arab = Arab + TB(i + 1) - TB(i)
            i = i + 2
        Else
            Arab = Arab + TB(i)
            i = i + 1
        End If
        Debug.Print Arab
    Wend
    RomainArabe = Arab
End Function
Function NBlettre(Deb As Byte) As Byte
Dim i As Integer, L As String
    NBlettre = 1
    L = Mid(Rm, Deb, 1)
    For i = Deb + 1 To Len(Rm)
        If Mid(Rm, i, 1) = L Then
            NBlettre = NBlettre + 1
        Else
            Exit Function
        End If
    Next
End Function
Function ValeurLettre(L As String) As Integer
Dim Romain, Arabe, i As Byte
    Romain = Array("I", "V", "X", "L", "C", "D", "M")
    Arabe = Array(1, 5, 10, 50, 100, 500, 1000)
    For i = 0 To 6
        If L = Romain(i) Then
            ValeurLettre = Arabe(i)
            Exit Function
        End If
    Next i
End Function

Exemple de formule à placer dans une feuille Excel
'=RomainArabe(A3)

CODE POUR VBA ET VB6

Coller le code ci-dessous dans un module général, Module1 par exemple pour le VBA
Ou dans un Module.bas pour VB6

Option Explicit
Dim Rm As String

Public Function TraduitRomain(Rm) As Integer
Dim TB
Dim Arab As Integer
Dim i As Byte, A As Integer, Utb As Integer

ReDim TB(0)
    i = 1: Utb = 1
    Rm = Replace(Rm, " ", "") 'supprime les espaces éventuels
    Rm = UCase(Rm) ' met en majuscule si nécessaire
    While i <= Len(Rm)
        'traite les lettres une a une
        ReDim Preserve TB(Utb)
        A = NBlettre(i)
        TB(Utb) = A * ValeurLettre(Mid(Rm, i, 1))
        Debug.Print TB(Utb)
        i = i + A
        Utb = Utb + 1
    Wend
    ReDim Preserve TB(Utb): i = 1
    While i < UBound(TB)
        If TB(i) < TB(i + 1) Then
             Arab = Arab + TB(i + 1) - TB(i)
            i = i + 2
        Else
            Arab = Arab + TB(i)
            i = i + 1
        End If
        Debug.Print Arab
    Wend
    TraduitRomain = Arab
End Function
Private Function NBlettre(Deb As Byte) As Byte
Dim i As Integer, L As String
    NBlettre = 1
    L = Mid(Rm, Deb, 1)
    For i = Deb + 1 To Len(Rm)
        If Mid(Rm, i, 1) = L Then
            NBlettre = NBlettre + 1
        Else
            Exit Function
        End If
    Next
End Function

Private Function ValeurLettre(L As String) As Integer
Dim Romain, Arabe, i As Byte
    Romain = Array("I", "V", "X", "L", "C", "D", "M")
    Arabe = Array(1, 5, 10, 50, 100, 500, 1000)
    For i = 0 To 6
        If L = Romain(i) Then
            ValeurLettre = Arabe(i)
            Exit Function
        End If
    Next i
End Function

Exemple d'appel de la fonction

Sub AppelEnArabic()
Dim R As String
    R = "MMMCMIC"
    MsgBox R & " en chiffre arabe donnerait " & TraduitRomain(R)
End Sub