[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.
Coller le code ci-dessous dans un module général, Module1 par exemple.
Exemple de formule à placer dans une feuille Excel
'=RomainArabe(A3)
Coller le code ci-dessous dans un module général, Module1 par exemple pour le VBA
Ou dans un Module.bas pour VB6
Exemple d'appel de la fonction
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
