VB / VBA - Rooma numbri teisendamine araabia keelde

Need funktsioonid võimaldavad muuta rooma "tähed" (MCMLXIX) araabia numbri kujul (1969). Need protseduurid on saadaval Exceli ja VBA jaoks kohandatud vormingus kasutajaformaadi jaoks. VBA kood on ühilduv VB6-ga.

Exceli funktsioon

Kleepige allolev kood üldmoodulisse, nt moodul1.

 Dim Rm kui stringi avalik funktsioon RomainArabe (C kui vahemik) Integer Dim TB Araabia kui tervikuna Dim i kui bait, A kui tervikuna, Utb kui tervikuna Kui C = "" Siis RomainArabe = 0: Välju funktsioon ReDim TB (0) Rakendus .Volatile i = 1: Utb = 1: Arab = 0 Rm = Asenda (C, "", "") "supprime les espaces éventuels Rm = UCase (Rm)" met en majuscule si nécessaire Kuigi i <= Len (Rm) TB-i säilitamise režiimi säilitamine (Utb) A = NBlettre (i) TB (Utb) = A * ValeurLettre (keskmine (Rm, i, 1)) Debug.Print TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim Preserve TB (Utb): i = 1 Kui i <UBound (TB) Kui TB (i) <TB (i + 1) Seejärel Araabia = araabia + TB (i + 1) - TB (i) i = i + 2 Else araabia = araabia + TB (i) i = i + 1 lõpp, kui debug.Print Arab Wend RomainArabe = Araabia lõppfunktsioon Funktsioon NBlettre (Deb aste) kui bait Dim i kui tervikuna, L kui string NBlettre = 1 L = keskmine (Rm, Deb, 1) i = Deb + 1 kuni Len (Rm) Kui keskel (Rm, i, 1) = L Siis NBlettre = NBlettre + 1 Else Exit Function End Kui järgmine lõppfunktsioon Funktsioon ValeurLettre ( L stringina ) Nagu Integer Dim Romain, Arabe, i Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) i = 0 kuni 6 korral, kui L = Romain (i) Siis ValeurLettre = Arabe (i) Exit Function End Kui järgmine i lõpp funktsioon 

Exceli arvutustabelisse paigutatava valemi näide

 '= RomainArabic (A3) 

VBA / VB6 koodid

Kleepige allolev kood üldmoodulisse, nt VBA moodul 1 või VB6 moodulisse.bas

 Võimalus Selgesõnaline Dim Rm kui stringi avalik funktsioon TraduitRomain (Rm) kui terviklik Dim TB Araabia kui tervikuna Dim i kui bait, A kui tervikuna, Utb kui terviklik ReDim TB (0) i = 1: Utb = 1 Rm = asendamine (Rm, "", "") "supprime les espaces éventuels Rm = UCase (Rm)" met en majuscule si nécessaire Kuigi i <= Len (Rm) 'on jäänud und a Reeim Preserve TB (Utb) A = NBlettre (i) TB (Utb) = A * ValeurLettre (keskmine (Rm, i, 1)) Debug.Print TB (Utb) i = i + A Utb = Utb + 1 Wend ReDim Preserve TB (Utb): i = 1 Kuigi i <UBound (TB) Kui TB (i) <TB (i + 1) Seejärel Araabia = araabia + TB (i + 1) - TB (i) i = i + 2 Else araabia = araabia + TB (i) i = i + 1 Lõpeta kui debug.Print Arab Wend TraduitRomain = Araabia lõppfunktsioon Privaatsfunktsioon NBlettre (Deb Aste) Byte Dim i kui tervikuna, L kui string NBlettre = 1 L = Mid (Rm, Deb, 1) i = Deb + 1-le Len (Rm) Kui keskel (Rm, i, 1) = L Siis NBlettre = NBlettre + 1 Else Exit Funktsioon Lõpeta, kui järgmine lõppfunktsioon Eraldi funktsioon ValeurLettre (L kui string) kui terviklik Dim Romain, Arabe, i Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) i = 0 kuni 6 Kui L = Romain (i) Siis ValeurLettre = Arabe (i) Exit Function End Kui Järgmine i Lõpeta funktsioon 

Funktsioonikõne näide:

 Sub AppelEnArabic () Dim R kui string R = "MMMCMIC" MsgBox R & "en chiffre arabe donnerait" & TraduitRomain (R) Lõpeta alam