VB / VBA - Convertir número romano a árabe
Estas funciones permiten la conversión de números expresados en "Letras" romanas (MCMLXIX) en formato de número árabe (1969). Estos procedimientos están disponibles como una función personalizada para Excel y en VBA para un formulario de usuario. El código VBA es compatible con VB6.
Función para Excel
Pegue el código a continuación en un módulo general, por ejemplo, Módulo 1.
Dim Rm As String Función pública RomainArabe (C As Range) As Integer Dim TB TB Arab Arab As Integer Dim i Aste, A As Integer, Utb As integer Si C = "" Entonces RomainArabe = 0: Salir de la función ReDim TB (0) Aplicación .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.Imprimir TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim Preserve TB (Utb): i = 1 Mientras que i <UBound (TB) Si TB (i) <TB (i + 1) Entonces Arab = Arab + TB (i + 1) - TB (i) i = i + 2 más Arab = Arab + TB (i) i = i + 1 End Si Debug.Print Arab Wend RomainArabe = Arab End Función Función NBlettre (Deb As Byte) Como Byte Dim i As Integer, L As String NBlettre = 1 L = Medio (Rm, Deb, 1) Para i = Deb + 1 A Len (Rm) Si Medio (Rm, i, 1) = L Entonces NBlettre = NBlettre + 1 Elé Salir Función Finalizar Si Siguiente Final Función Función ValeurLettre ( L como cuerda ) Como Entero Dim Romain, Arabe, i As Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) Para i = 0 a 6 Si L = Romain (i) Entonces ValeurLettre = Arabe (i) Salir de la función Finalizar si es siguiente i Final de la función Ejemplo de una fórmula para colocar en una hoja de cálculo de Excel
'= RomainArabic (A3)
Códigos VBA / VB6
Pegue el código a continuación en un módulo general, por ejemplo, Module1 para VBA o en Module.bas para VB6
Opción Explícito Dim Rm As String Función pública TraduitRomain (Rm) As entero Dim TB TB Arab 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. Imprimir TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim Preserve TB (Utb): i = 1 While i <UBound (TB) Si TB (i) <TB (i + 1), entonces árabe = árabe + TB (i + 1) - TB (i) i = i + 2 más Árabe = árabe + TB (i) i = i + 1 End If Debug.Print Arab Wend TraduitRomain = Arab End Function Función privada NBlettre (Deb As Byte) Como Byte Dim i As Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) Para i = Deb + 1 To Len (Rm) Si Mid (Rm, i, 1) = L Then NBlettre = NBlettre + 1 Else Exit Función End Si Next End End Función Función privada ValeurLettre (L como cadena) Como entero Dim Romain, Arabe, i As By Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) Para i = 0 a 6 Si L = Romain (i) Entonces ValeurLettre = Arabe (i) Salir de la función Finalizar si Siguiente i Final de la función Ejemplo de llamada a función:
Sub AppelEnArabic () Dim R As String R = "MMMCMIC" MsgBox R & "en chiffre arabe donnerait" & TraduitRomain (R) End Sub