[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
Ce document intitulé « [VB/VBA] Conversion nombre Romain -> Arabe » issu de Comment Ça Marche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.