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
Cet article est régulièrement mis à jour par des experts sous la direction de Jean-François Pillou, fondateur de CommentCaMarche et directeur délégué au développement numérique du groupe Figaro.
