VB/VBA - Conversão número romano -> Árabe

Dezembro 2016


Estas funções permitem converter números romanos escritos em « letras » do tipo MCMLXIX em número no formato árabe, ou seja, 1969.

Estes procedimentos são disponíveis em função personalizada para Excel e em VBA para um
Userform.

O código VBA é compatível com VB6.



Função personalizada para Excel


Colar o código abaixo em um módulo geral, Module1 por exemplo.
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, " ", "") 'suprime os espaços eventuais 
    Rm = UCase(Rm) ' coloca em maiúscula se necessário 
    While i <= Len(Rm) 
        'trata as letras uma a uma 
        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 ValoLetra(L As String) As Integer 
Dim Romano, Árabe, i As Byte 
    Romano = Array("I", "V", "X", "L", "C", "D", "M") 
    Árabe = Array(1, 5, 10, 50, 100, 500, 1000) 
    For i = 0 To 6 
        If L = Romain(i) Then 
            ValorLetra = Árabe(i) 
            Exit Function 
        End If 
    Next i 
End Function

Exemplo de fórmula a colocar na folha Excel
'=RomanoÁrabe(A3)

Código para VBA e VB6


Colar o código acima n módulo geral, Módulo1, por exemplo, para o VBA
Ou no módulo.bas para VB6
Opção Explicita 
Dim Rm As String 

Publica Função TraduizidaRomano(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, " ", "") 'suprime os espaços eventuais 
    Rm = UCase(Rm) ' met em maiúscula se necessário 
    While i <= Len(Rm) 
        'trata as letras uma a uma 
        ReDim Preserve TB(Utb) 
        A = NBletra(i) 
        TB(Utb) = A * ValorLetra (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 
    TraduzRomano = Arab 
End Function 
Private Function NBlettre(Deb As Byte) As Byte 
Dim i As Integer, L As String 
    NBletra = 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 ValorLetra(L As String) As Integer 
Dim Romano, Árabe, i As Byte 
    Romano = Array("I", "V", "X", "L", "C", "D", "M") 
    Árabe = Array(1, 5, 10, 50, 100, 500, 1000) 
    For i = 0 To 6 
        If L = Romano(i) Then 
            ValorLetra = Árabe(i) 
            Exit Function 
        End If 
    Next i 
End Function

Exemplo de chamada da função

Sub AppelEnArabic() 
Dim R As String 
    R = "MMMCMIC" 
    MsgBox R & " em número árabe daria " & TraduzRomano(R) 
End Sub



Tradução feita por Ana spadari

Veja também :
Este documento, intitulado « VB/VBA - Conversão número romano -> Árabe »a partir de CCM (br.ccm.net) está disponibilizado sob a licença Creative Commons. Você pode copiar, modificar cópias desta página, nas condições estipuladas pela licença, como esta nota aparece claramente.