0
Thanks

A few words of thanks would be greatly appreciated.

VB/VBA - Convert Roman number to Arabic




These functions allow the conversion of numbers expressed in Roman "letters" (MCMLXIX ) in Arabic number format (1969). These procedures are available as a custom function for Excel and in VBA for a Userform. VBA code is compatible with VB6.

Function for Excel


Paste the code below in a general module, e.g Module1.
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 


Example of a formula to be placed in an Excel spreadsheet
'=RomainArabic(A3)  

VBA/ VB6 Codes




Paste the code below in a general module, e.g Module1 for VBA or in a Module.bas for 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


Example of function call:

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

0
Thanks

A few words of thanks would be greatly appreciated.

Ask a question
CCM is a leading international tech website. Our content is written in collaboration with IT experts, under the direction of Jeff Pillou, founder of CCM.net. CCM reaches more than 50 million unique visitors per month and is available in 11 languages.
This document, titled « VB/VBA - Convert Roman number to Arabic », is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).

0 Comments