VB / VBA - Převést římské číslo na arabštinu

Tyto funkce umožňují převod čísel vyjádřených v římských "písmenech" (MCMLXIX) v arabském číslovém formátu (1969). Tyto postupy jsou k dispozici jako vlastní funkce pro Excel a VBA pro Userform. Kód VBA je kompatibilní s VB6.

Funkce pro Excel

Vložte níže uvedený kód do obecného modulu, např. Module1.

 Dim Rm jako funkce String Public Funkce RomainArabe (C jako rozsah) Jako celé číslo Dim TB Dim Arab jako celé číslo Dim i jako bajt, A jako celé číslo, Utb jako celé číslo Pokud C = "" Pak RomainArabe = 0: Ukončit funkci ReDim TB (0) Aplikace .Volatile i = 1: Utb = 1: Arab = 0 Rm = Nahradit (C, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' met en majuscule si nécessaire Zatímco i <= Len (Rm) 'Traite les lettres une a une ReDim Zachovat 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 Zachovat TB (Utb): i = 1 Zatímco i <UBound (TB) Pokud TB (i) <TB (i + 1) Pak Arab = Arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = Arab + TB (i) i = i + 1 Konec Pokud Debug.Print Arab Wend RomainArabe = Funkce arabského konce Funkce NBlettre (Deb As Byte) Jako Byte Dim i Integer, L jako řetězec NBlettre = 1 L = Střední (Rm, Deb, 1) Pro i = Deb + 1 To Len (Rm) Pokud Střední (Rm, i, 1) = L Pak NBlettre = NBlettre + 1 Else Konec Funkce Konec Pokud Další Konec Funkce Funkce ValeurLettre ( L jako řetězec ) Jako Integer Dim Romain, Arabe, i Jako Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5), 10, 50, 100, 500, 1000) Pro i = 0 až 6 Pokud L = Romain (i) Pak ValeurLettre = Arabe (i) Konec funkce End If Next Function 

Příklad vzorce, který má být umístěn v tabulce aplikace Excel

 '= RomainArabic (A3) 

Kódy VBA / VB6

Vložte níže uvedený kód do obecného modulu, např. Module1 pro VBA nebo do Module.bas pro VB6

 Možnost Explicit Dim Rm As String Public Funkce TraduitRomain (Rm) Jako celé číslo Dim TB Dim Arab jako celé číslo Dim i jako bajt, A jako celé číslo, Utb jako celé číslo ReDim TB (0) i = 1: Utb = 1 Rm = Nahradit (Rm, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' met en majuscule si nécessaire Zatímco i <= Len (Rm) 'traite les lettres une a une ReDim Preserve TB (Utb) A = NBlettre (i) TB (Utb) = A * ValeurLettre (Střední (Rm, i, 1)) Debug.Print TB (Utb) i = i + Utb = Utb + 1 Wend ReDim Zachovat TB (Utb): i = 1 Zatímco i <UBound (TB) Pokud TB (i) <TB (i + 1) Pak 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 Soukromá funkce NBlettre (Deb As Byte) Jako Byte Dim i Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) Pro i = Deb + 1 To Len (Rm) Pokud Mid (Rm, i, 1) = L Pak NBlettre = NBlettre + 1 Else Konec Funkce Konec Pokud Další Konec Funkce Soukromá funkce ValeurLettre (L As String) Jako 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) i = 0 až 6 Pokud L = Romain (i) Pak ValeurLettre = Arabe (i) Konec funkce konce, pokud Next i End Function 

Příklad volání funkce:

 Sub AppelEnArabic () Dim R jako řetězec R = "MMMCMIC" MsgBox R & "en chiffre arabe donnerait" & TraduitRomain End Sub