VB / VBA - Konvertiert römische Zahlen in Arabisch

Diese Funktionen ermöglichen die Umwandlung von Zahlen, die in römischen "Buchstaben" (MCMLXIX) ausgedrückt werden, in arabische Zahlenformate (1969). Diese Verfahren sind als benutzerdefinierte Funktion für Excel und in VBA für ein Benutzerformular verfügbar. VBA-Code ist mit VB6 kompatibel.

Funktion für Excel

Fügen Sie den folgenden Code in ein allgemeines Modul ein, z. B. Module1.

 Dim Rm As String Öffentliche Funktion RomainArabe (C As Range) As Integer Dim TB Dim Arab As Integer Dim i As Byte, A As Integer, Utb As Integer Wenn C = "", dann RomainArabe = 0: Exit Function ReDim TB (0) Application .Volatile i = 1: Utb = 1: Arab = 0 Rm = Ersetzen (C, "", "") Sie können 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 TB erhalten (Utb): i = 1, während i <UBound (TB) Wenn TB (i) <TB (i + 1), dann Arab = Arab + TB (i + 1) - TB (i) i = i + 2 Sonst Arab = Arab + TB (i) i = i + 1 Ende wenn Debug.Print Arab Wend RomainArabe = Arab Ende Funktion Funktion NBlettre (Deb als Byte) As Byte Dim i As Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) Für i = Deb + 1 bis Len (Rm) Wenn Mid (Rm, i, 1) = L, dann ist NBlettre = NBlettre + 1 Andernfalls wird die Funktion beendet, wenn die Funktion am nächsten Ende endet. L Als Zeichenfolge ) Als Integer Dim Romain, Arabe, i Als Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) Für i = 0 bis 6 Wenn L = Romain (i), dann ValeurLettre = Arabe (i) Funktion beenden, wenn nächste i Funktion beenden 

Beispiel einer Formel, die in eine Excel-Tabelle eingefügt werden soll

 '= RomainArabic (A3) 

VBA / VB6-Codes

Fügen Sie den folgenden Code in ein allgemeines Modul ein, z. B. Module1 für VBA oder Module.bas für VB6

 Option Explicit Dim Rm As String Öffentliche Funktion 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 TB (Utb) = A * ValeurLettre (Mid (Rm, i, 1)) Debug.Print TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim TB erhalten (Utb): i = 1 Solange i <UBound (TB) Wenn TB (i) <TB (i + 1), dann ist Arabisch = Arabisch + TB (i + 1) - TB (i) i = i + 2, ansonsten Arabisch = Arabisch + TB (i) i = i + 1 End If Debug.Print Arab Wend TraduitRomain = Arab End Function Private Funktion NBlettre (Deb als Byte) As Byte Dim i As Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) For i = Deb + 1 To Len (Rm) Wenn Mid (Rm, i, 1) = L Dann NBlettre = NBlettre + 1 Andernfalls Beenden der Funktion End If Next End-Funktion Private Funktion ValeurLettre (L As String) Als Ganzzahl 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 bis 6 Wenn L = Romain (i), dann ValeurLettre = Arabe (i) Funktion beenden, wenn nächstes i Funktion beenden 

Beispiel eines Funktionsaufrufs:

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