VB / VBA - pretvorite rimsko številko v arabsko

Te funkcije omogočajo pretvorbo številk, izraženih v rimskih "črkah" (MCMLXIX) v arabskem formatu številk (1969). Ti postopki so na voljo kot funkcija po meri za Excel in VBA za uporabniško obliko. VBA koda je združljiva z VB6.

Funkcija za Excel

Prilepite spodnjo kodo v splošni modul, npr. Modul1.

 Dim Rm Kot String Javna Funkcija RomainArabe (C As Range) Kot Integer Dim TB Dim Arab Kot Integer Dim i Kot Byte, A Kot Integer, Utb Kot Integer Če C = "" Potem RomainArabe = 0: Izhod Funkcija ReDim TB (0) Application .Volatile i = 1: Utb = 1: Arab = 0 Rm = Zamenjaj (C, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' je en majuscule in nécessaire Medtem ko i <= Len (Rm) "Traite les lettres une a une ReDim Ohranite TB (Utb) A = NB (i) TB (Utb) = A * ValeurLettre (Mid (Rm, i, 1)) Debug.Print TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim Ohrani TB (Utb): i = 1 Medtem ko i <UBound (TB) Če je TB (i) <TB (i + 1), potem Arab = Arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = Arab + TB (i) i = i + 1 Konec Če Debug.Print Arab Wend RomainArabe = Arabska funkcija Funkcija NBlettre (Deb kot bajt) Kot bajt Dim i Kot celo število, L kot niz NBlettre = 1 L = Mid (Rm, Deb, 1) Za i = Deb + 1 Za Len (Rm) Če je Mid (Rm, i, 1) = L Potem NBlettre = NBlettre + 1 Else Izhod Funkcija End Če Next End Funkcija Funkcija ValeurLettre ( L kot niz ) Kot Integer Dim Romain, Arabe, i Kot Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5), 10, 50, 100, 500, 1000) Za i = 0 do 6 Če je L = Romain (i), potem ValeurLettre = Arabe (i) Izhod Funkcija End Če Next i End funkcija 

Primer formule, ki jo je treba postaviti v Excelovo preglednico

 '= RomainArabic (A3) 

Kode VBA / VB6

Prilepite spodnjo kodo v splošni modul, npr. Modul1 za VBA ali v Module.bas za VB6

 Možnost Izrecno Dim Rm Kot Niz Javna Funkcija TraduitRomain (Rm) Kot Integer Dim TB Dim Arab Kot Integer Dim i Kot Byte, A Kot Integer, Utb Kot Integer ReDim TB (0) i = 1: Utb = 1 Rm = Zamenjaj (Rm, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' je izpisan tako, da ni mogoče izbrati, če je <= Len (Rm) 'shranjen kot nepovratni vir za ohranitev TB (Utb) A = vrednost (i) TB (Utb) = A * ValeurLettre (Srednja (Rm, i, 1)) Debug.Print TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim Ohrani TB (Utb): i = 1 Medtem ko i <UBound (TB) Če je TB (i) <TB (i + 1), potem Arab = Arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = Arab + TB (i) i = i + 1 Konec Če je Debug.Print Arab Wend TraduitRomain = arab Konec Funkcija zasebna funkcija NBlettre (Deb kot bajt) Kot bajt Dim i kot celo število, L kot niz NBlettre = 1 L = Mid (Rm, Deb, 1) Za i = Deb + 1 Len (Rm) If Mid (Rm, i, 1) = L Potem NBlettre = NBlettre + 1 Else Izhod Funkcija End Če Next End Funkcija Private Function ValeurLettre (L kot niz) Kot Integer Dim Romain, Arabe, i Kot Byte Romain = Matrika ("I", "V", "X", "L", "C", "D", "M") Arabe = matrika (1, 5, 10, 50, 100, 500, 1000) i = 0 do 6 Če je L = Romain (i), potem ValeurLettre = Arabe (i) Izhod Funkcija End If Next i Funkcija konca 

Primer klica funkcije:

 Sub AppelEnArabic () Dim R kot niz R = "MMMCMIC" MsgBox R & "en chiffre arabe donnerait" & TraduitRomain (R) End Sub