VB / VBA - Converti il ​​numero romano in arabo

Queste funzioni consentono la conversione di numeri espressi in "lettere" romane (MCMLXIX) in formato numerico arabo (1969). Queste procedure sono disponibili come funzione personalizzata per Excel e in VBA per un modulo utente. Il codice VBA è compatibile con VB6.

Funzione per Excel

Incolla il codice qui sotto in un modulo generale, ad es. Module1.

 Dim Rm As String Funzione pubblica RomainArabe (C As Range) As Integer Dim TB Dim Arab As Integer Dim i As Byte, A As Integer, Utb As Integer If C = "" Quindi RomainArabe = 0: Exit Function ReDim TB (0) Applicazione .Volatile i = 1: Utb = 1: Arabo = 0 Rm = Sostituisci (C, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' incontrato in majuscule si nécessaire While i <= Len (Rm) 'traite le lettere 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 Preserve TB (Utb): i = 1 While i <UBound (TB) If TB (i) <TB (i + 1) Then Arab = Arab + TB (i + 1) - TB (i) i = i + 2 Else Arab = Arab + TB (i) i = i + 1 End If Debug.Print Arab Wend RomainArabe = Arab End Funzione Funzione NBlettre (Deb As Byte) Come Byte Dim i As Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) Per i = Deb + 1 A Len (Rm) Se Medio (Rm, i, 1) = L Quindi NBlettre = NBlettre + 1 Else Esci Funzione Termina Se Successivo Fine Funzione Funzione ValeurLettre ( L As String ) Integer Dim Romain, Arabe, i As Byte Romain = Array ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) Per i = 0 A 6 Se L = Romain (i) Allora ValeurLettre = Arabe (i) Esci Funzione Fine Se Avanti i Fine Funzione 

Esempio di una formula da inserire in un foglio di calcolo di Excel

 '= RomainArabic (A3) 

Codici VBA / VB6

Incollare il codice sottostante in un modulo generale, ad es. Module1 per VBA o in Module.bas per VB6

 Opzione Esplicita Dim Rm As String Funzione pubblica TraduitRomain (Rm) As Integer Dim TB Dim Arab As Integer Dim i As Byte, A As Integer, Utb As Integer ReDim TB (0) i = 1: Utb = 1 Rm = Sostituisci (Rm, "", "") 'supprime les espaces éventuels Rm = UCase (Rm)' incontrato in majuscule si nécessaire While i <= Len (Rm) 'traite les lettres une 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 Preserve TB (Utb): i = 1 While i <UBound (TB) Se TB (i) <TB (i + 1) Then 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 Funzione privata NBlettre (Deb As Byte) As Byte Dim i As Integer, L As String NBlettre = 1 L = Mid (Rm, Deb, 1) Per i = Deb + 1 To Len (Rm) If Mid (Rm, i, 1) = L Quindi NBlettre = NBlettre + 1 Else Exit Funzione End If Next End Function Funzione privata ValeurLettre (L As String) Come intero Dim Romain, Arabe, i As Byte Romain = Matrice ("I", "V", "X", "L", "C", "D", "M") Arabe = Array (1, 5, 10, 50, 100, 500, 1000) Per i = 0 a 6 se L = Romain (i) Then ValeurLettre = Arabe (i) Esci Funzione Termina se Avanti i Fine Funzione 

Esempio di chiamata di funzione:

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