VB / VBA - Previesť rímske číslo na arabčinu

Tieto funkcie umožňujú konverziu čísel vyjadrených v rímskych "písmenách" (MCMLXIX) v arabskom číslovanom formáte (1969). Tieto postupy sú k dispozícii ako vlastná funkcia pre program Excel a vo formáte VBA pre používateľský formulár. Kód VBA je kompatibilný s VB6.

Funkcia pre Excel

Vložte nižšie uvedený kód do všeobecného modulu, napr. Module1.

 Dim Rm As String Public Funkcia RomainArabe (C As Range) Ako Integer Dim TB Dim Arab As Integer Dim i As Byte, A As Integer, Utb As Integer Ak C = "" Potom RomainArabe = 0: Funkcia ukončenia ReDim TB (0) Aplikácia .Volatile i = 1: Utb = 1: Arab = 0 Rm = Nahradiť (C, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' met en majuscule si nécessaire Zatiaľ čo 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 Zachovať TB (Utb): i = 1 Zatiaľ čo i <UBound (TB) Ak TB (i) <TB (i + 1) Potom Arab = Arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = Arab + TB (i) i = i + 1 Koniec Ak Debug.Print Arab Wend RomainArabe = Funkcia arabského konca Funkcia NBlettre (Deb As Byte) Ako Byte Dim i Integer, L As String NBlettre = 1 L = Stred (Rm, Deb, 1) Pre i = Deb + 1 To Len (Rm) Ak Mid (Rm, i, 1) = L Potom NBlettre = NBlettre + 1 Else Koniec Funkcia Koniec Ak Nasledujúci Koniec Funkcia Funkcia ValeurLettre ( L ako reťazec ) Ako Integer Dim Romain, Arabe, i Ako Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5), 10, 50, 100, 500, 1000) Pre i = 0 až 6 Ak L = Romain (i) Potom ValeurLettre = Arabe (i) Ukončenie funkcie End Ak Next i End Function 

Príklad vzorca, ktorý sa má umiestniť do tabuľky programu Excel

, = RomainArabic (A3) 

Kódy VBA / VB6

Vložte nasledujúci kód do všeobecného modulu, napr. Module1 pre VBA alebo do Module.bas pre VB6

 Možnosť Explicit Dim Rm As String Public Funkcia TraduitRomain (Rm) Ako celé číslo Dim TB Dim Arab As Integer Dim i As Byte, A As Integer, Utb As Integer ReDim TB (0) i = 1: Utb = 1 Rm = Nahradiť (Rm, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' met en majuscule si nécessaire Zatiaľ čo i <= Len (Rm) 'traite les lettres une a une ReDim Preserve TB (Utb) A = NBlettre (i) TB (Utb) = A * ValeurLettre (Stred (Rm, i, 1)) Debug.Print TB (Utb) i = i + Utb = Utb + 1 Wend ReDim Zachovať TB (Utb): i = 1 Zatiaľ čo i <UBound (TB) Ak TB (i) <TB (i + 1) Potom 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 Súkromná funkcia NBlettre (Deb As Byte) Ako Byte Dim i Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) Pre i = Deb + 1 To Len (Rm) Ak Mid (Rm, i, 1) = L Potom NBlettre = NBlettre + 1 Else Koniec Funkcia Koniec Ak Nasledujúci Koniec Funkcia Súkromná funkcia ValeurLettre (L As String) Ako Integer Dim Romain, Arabe, i As Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = pole (1, 5, 10, 50, 100, 500, 1000) pre i = 0 Do 6 Ak L = Romain (i) Potom ValeurLettre = Arabe (i) Ukončenie funkcie End Ak funkcia Next i End 

Príklad volania funkcie:

 Sub AppelEnArabic () Dim R ako reťazec R = "MMMCMIC" MsgBox R & "en chiffre arabe donnerait" & TraduitRomain End Sub