VB / VBA - A római számot arabra konvertálja
Ezek a funkciók lehetővé teszik a római betűkkel (MCMLXIX) kifejezett számok arab számformátumban (1969) történő átalakítását. Ezek az eljárások egyéni funkcióként elérhetők az Excel és a VBA számára egy Userform számára. A VBA kód kompatibilis a VB6-tal.
Az Excel funkciója
Illessze be az alábbi kódot egy általános modulba, pl.
Dim Rm mint karakterlánc nyilvános függvényként RomainArabe (C mint tartomány) Integer Dim TB-ként Arab mint integer Dim i byte, A mint integer, Utb mint integer Ha C = "" majd RomainArabe = 0: Kilépés funkció ReDim TB (0) Alkalmazás .Volatile i = 1: Utb = 1: Arab = 0 Rm = Csere (C, "", "") "supprime les espaces éventuels Rm = UCase (Rm)" met en majuscule si nécessaire Míg i <= Len (Rm) A „TBT-t megőrzi” (Utb) A = NBlettre (i) TB (Utb) = A * ValeurLettre (Közép (Rm, i, 1)) Debug.Print TB (Utb) i = i + A Utb = Utb + 1 ReDim megőrzése TB (Utb): i = 1 Míg i <UBound (TB) Ha TB (i) <TB (i + 1) Ezután Arab = arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = Arab + TB (i) i = i + 1 Vége Ha Debug.Print Arab Wend RomainArabe = Arab végfunkció Funkció NBlettre (Deb as byte) Bájtként Dim i Mint Integer, L Mint String NBlettre = 1 L = Közép (Rm, Deb, 1) i = Deb + 1 - Len (Rm) Ha közép (Rm, i, 1) = L Ezután NBlettre = NBlettre + 1 Else Exit funkció vége Ha a következő végfunkció funkciója ValeurLettre ( L karakterláncként Integer Dim Romain, Arabe, i Bájt Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) i = 0-tól 6-ig Ha L = Romain (i) ValeurLettre = Arabe (i) Kilépési funkció vége Ha a következő i végződik Példa egy képletre, amelyet egy Excel táblázatba kell helyezni
„= RomainArabic (A3)
VBA / VB6 kódok
Illessze be az alábbi kódot egy általános modulba, pl. V1 modulba, vagy egy VB6 modulba
Opció Kifejezetten Dim Rm mint String Nyilvános funkció TraduitRomain (Rm) Integer Dim TB-ként Arab, mint Integer Dim i Bájtként, A Mint Integer, Utb mint Integer ReDim TB (0) i = 1: Utb = 1 Rm = Csere (Rm, "", "") "supprime les espaces éventuels Rm = UCase (Rm)" met en majuscule si nécessaire Míg az i <= Len (Rm) 'a ReDim megőrzése 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 Preserve TB (Utb): i = 1 Míg i <UBound (TB) Ha TB (i) <TB (i + 1) Ezután Arab = arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = arab + TB (i) i = i + 1 Vége Ha Debug.Print Arab Wend TraduitRomain = Arab végfunkció Privát függvény NBlettre (Deb as byte) Bájtként Dim i mint teljes érték, L karakterláncként NBlettre = 1 L = Közép (Rm, Deb, 1) Az i = Deb + 1 számára Len (Rm) Ha közepes (Rm, i, 1) = L Ezután NBlettre = NBlettre + 1 Else Kilépés funkció Vége Ha a következő végpont funkciója Privát függvény ValeurLettre (L mint karakterlánc) 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-tól 6-ig Ha L = Romain (i) ValeurLettre = Arabe (i) Kilépés funkció vége Ha a következő i vége funkció Példa a funkcióhívásra:
Sub AppelEnArabic () Dim R, mint karakterlánc R = "MMMCMIC" MsgBox R & "en chiffre arabe donnerait" & TraduitRomain (R) End Sub