How to generate a full value in Portuguese in MS Office Excel?

Question

In an Excel spreadsheet, having a cell with a numerical value, how to calculate its value in full?

For example, in the cell A1 have the value R$ 587,32.
I need a function that passes the cell as parameter, returns the text:

Quinhentos e oitenta e sete reais, trinta e dois centavos

Answer 1

Below is a VBA function that returns the full value of a number passed as parameter, in addition to allowing some return settings.

' Função que retorna valores por extenso
' Params:
'    Num (Double) : valor numérico a ser calculado seu valor por extenso
'    Opcional FraçTipo (Integer) : opção de como representar a parte fracionária
'        1 ou 5 - Lê fração em centavos ou cêntimos. Ideal para Moeda.
'        2 - Lê a vírgula decimal, cada zero e o número restante como inteiro. Ideal para percentual.
'        3 - Lê a fração de décimo a bilionésimo. Ideal para número puro.
'        4 - Não lê a fração mas escreve como fração com um denominador de 100, 1000, 1000000... Ideal para moeda com fração de milésimo
'    Opcional UndNomeSing (String) : Nome da unidade monetária, no singular.
'    Opcional UndNomePlur (String) : Nome da unidade monetária, no plural.
'    Opcional UndMasc (Boolean - default True) : Unidade é do gênero masculino.
'    Opcional UmMil (Boolean - default True) : Não omitir o "UM" em "UM MIL".
'    Opcional VirgEntrMilh (Boolean - default False) : Usar vírgula entre milhares.
'    Opcional CaixaAlta (Long - default 1) : Estilo de capitalização do texto
'        1 - Todo o texto em minúsculo.
'        2 - Apenas a primeira letra do texto em Maiúsculo, o restante em minúsculo.
'        3 - Capitaliza A Primeira Letra de Cada Palavra, Com Exceção da Conjunção "e".
'        4 - Todo o texto em MAIÚSCULO.
Function fExtenso(Num As Double, Optional FraçTipo As Integer, Optional UndNomeSing As String, _
        Optional UndNomePlur As String, Optional UndMasc As Boolean = True, _
        Optional UmMil As Boolean = True, Optional VirgEntrMilh As Boolean = False, _
        Optional CaixaAlta As Long = 1) As String
    Dim ExtensInt As String
    Dim ExtensFrac As String
    Dim UndNome As String
    Dim FracNome As String
    Dim Signif As Long
    Dim NumText As String

    If Num > 999999999999.99 Or Num < 0 Then
        fExtenso = "Erro! (Valores válidos: >=0 e < 1 trilhão)"
        Exit Function
    End If

    'Preparando nome da unidade, singular e plural
    If UndNomePlur = "" Then UndNomePlur = IIf(UndNomeSing = "", "", Pluralizar(UndNomeSing))
    'Se a função Pluralizar falhar palavras estrangeiras ou em exceções portuguesas, o argumento UndNomePlur pode ser usado.

    'Extenso parte inteira
    ExtensInt = fExtensoInt(Int(CDec(Num)), UndMasc, UmMil, VirgEntrMilh)

    'Extenso parte fracionária
    If FraçTipo = 0 And UndNomeSing = "" Then FraçTipo = 3
    If FraçTipo = 0 And UndNomeSing <> "" Then FraçTipo = 1
    Select Case FraçTipo
    Case 1, 5   'Lê fração em centavos ou cêntimos. Ideal para Moeda
        Num = Format(Num, "0.00") * 1   'Round(Num,2)
        ExtensFrac = fExtensoInt((Num - Int(CDec(Num))) * 100, True, UmMil, VirgEntrMilh)
        If ExtensInt = "" And ExtensFrac = "" Then ExtensInt = "zero"

        'Nome da unidade no singular ou plural
        UndNome = IIf(Num < 1, IIf(Num = 0, " " & UndNomePlur, ""), IIf(UndNomeSing = "" Or Right(ExtensInt, 1) = " ", "", " ") & IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) & IIf(Num = Int(CDec(Num)), "", " e "))
        'Nome da fração no singular ou plural
        FracNome = IIf(Num = Int(CDec(Num)), "", IIf(Int(CDec(Num * 100)) - Int(CDec(Num)) * 100 = 1, IIf(FraçTipo = 5, " cêntimo", " centavo"), IIf(FraçTipo = 5, " cêntimos", " centavos")))

        fExtenso = ExtensInt & UndNome & ExtensFrac & FracNome

    Case 2    'Lê a vírgula decimal, cada zero e o número restante como inteiro. Ideal para percentual.
        ExtensFrac = Num - Int(CDec(Num))
        If ExtensFrac = 0 Then
            fExtenso = ExtensInt
        Else
            ExtensFrac = Format(ExtensFrac, "0.############")
            ExtensFrac = Mid(ExtensFrac, 3, 15)
            fExtenso = IIf(ExtensInt = "", "zero", ExtensInt) & " vírgula"
            Do While Left(ExtensFrac, 1) = "0"
                fExtenso = fExtenso & " zero"
                ExtensFrac = Mid(ExtensFrac, 2, 15)
            Loop
            fExtenso = fExtenso & " " & fExtensoInt(ExtensFrac * 1, UndMasc, UmMil, VirgEntrMilh)
        End If

        If fExtenso = "" Then fExtenso = "zero"

        fExtenso = fExtenso & IIf(UndNomeSing <> "", " ", "") & IIf(Num = 1, UndNomeSing, UndNomePlur)

    Case 3    'Lê a fração de décimo a bilionésimo. Ideal para número puro.
        ExtensFrac = Num - Int(CDec(Num))
        If ExtensFrac = 0 Then
            ExtensFrac = ""
        Else
            ExtensFrac = Format(ExtensFrac, "0.############")
            Signif = Len(ExtensFrac) - 2
            If Signif > 3 And Signif <> 6 And Signif <> 9 And Signif <> 12 Then Signif = Int(CDec(Signif / 3)) * 3 + 3
            If Signif > 0 Then
                ExtensFrac = Format(ExtensFrac, "0.000000000000")
                ExtensFrac = fExtensoInt(Mid(ExtensFrac, 3, Signif) * 1, True, UmMil, VirgEntrMilh)
                FracNome = Choose(Signif, "décimo", "centésimo", "milésimo", , , "milionésimo", , , "bilionésimo", , , "trilionésimo")
                FracNome = " " & FracNome & IIf(ExtensFrac = "um", "", "s")
            Else
                ExtensFrac = ""
            End If
        End If

        If ExtensInt = "" And ExtensFrac = "" Then ExtensInt = "zero"

        If UndNomeSing = "" Then
            fExtenso = ExtensInt & IIf(ExtensInt <> "" And ExtensFrac <> "", ", e ", "") & ExtensFrac & FracNome
        Else
            'Nome da unidade no singular ou plural
            UndNome = IIf(Num < 1, IIf(Num = 0, " " & UndNomePlur, ""), IIf(UndNomeSing = "" Or Right(ExtensInt, 1) = " ", "", " ") & IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) & IIf(Num = Int(CDec(Num)), "", " e "))
            'Nome da fração no singular ou plural
            FracNome = IIf(Num = Int(CDec(Num)), "", FracNome & " de " & UndNomeSing)

            fExtenso = ExtensInt & UndNome & ExtensFrac & FracNome
        End If

    Case 4    'Não lê a fração mas escreve como fração com um denominador de 100, 1000, 1000000... Ideal para moeda com fração de milésimo
        ExtensFrac = Num - Int(CDec(Num))
        If ExtensFrac = 0 Then
            ExtensFrac = "nenhum/100"
        Else
            ExtensFrac = Format(ExtensFrac, "0.############")
            Signif = Len(ExtensFrac) - 2
            If Signif > 3 And Signif <> 6 And Signif <> 9 And Signif <> 12 Then Signif = Int(CDec(Signif / 3)) * 3 + 3
            If Signif > 1 Then
                ExtensFrac = (Num - Int(CDec(Num))) * 10 ^ Signif
                ExtensFrac = ExtensFrac & "/" & 10 ^ Signif
            Else
                ExtensFrac = (Num - Int(CDec(Num))) * 10 ^ 2
                ExtensFrac = ExtensFrac & "/100"
            End If
        End If

        If ExtensInt = "" Then ExtensInt = "zero"

        'Nome da unidade no singular ou plural
        UndNome = IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur)

        fExtenso = ExtensInt & " " & UndNome & " e " & ExtensFrac
    End Select

    Select Case CaixaAlta
    Case 1
        fExtenso = LCase(fExtenso)
    Case 2
        fExtenso = UCase(Left(fExtenso, 1)) & Mid(fExtenso, 2)
    Case 3
        fExtenso = StrConv(fExtenso, vbProperCase)
        fExtenso = MyReplace(fExtenso, " E ", " e ")
    Case 4
        fExtenso = StrConv(fExtenso, vbUpperCase)
    End Select

    'Preservar caixa alta de letra antes de ponto em UndNome
    Dim lPos As Long
    Dim lPos1 As Long
    Do While InStr(lPos + 1, UndNome, ".") > 1
        lPos = InStr(lPos + 1, UndNome, ".")
        lPos1 = InStr(lPos1 + 1, fExtenso, ".")
        fExtenso = Left(fExtenso, lPos1 - 2) & Mid(UndNome, lPos - 1, 1) & Mid(fExtenso, lPos1)
    Loop
End Function

Private Function fExtensoInt(Num As Double, UndMasc As Boolean, UmMil As Boolean, VirgEntrMilh As Boolean) As String
'Gramática portuguesa:
'Regra Geral: Não se intercala a conjunção 'e' e nem vírgula entre posições de milhar.
'Exceção: Se a milhar posterior for menor que 100 ou for centena inteira (100,200,300...)
'Alguns gramáticos não aceitam essa exceção e outros já aceitam a vírgula.
'A variável ConjExc ativa/desativa a exceção
'A variável VirgEntrMilh usa vírgula entre milhares

   Dim NumText As String
   Dim Ce As String
   Dim Ma As String
   Dim Mõ As String
   Dim Bi As String
   Dim f As String
   Dim ConjExc As Boolean
   ConjExc = True
   If VirgEntrMilh Then ConjExc = False

   If Num = 0 Then
      fExtensoInt = ""
      Exit Function
   End If

   NumText = Format(Num, "000,000,000,000")

   '1º Posição de milhar, Centenas
   Ce = Mid(NumText, 13, 3)
   '2º Posição de milhar, Milhares
   Ma = Mid(NumText, 9, 3)
   '3º Posição de milhar, Milhões
   Mõ = Mid(NumText, 5, 3)
   '4º Posição de milhar, Bilhões
   Bi = Mid(NumText, 1, 3)

   f = fMilharText(Bi, UndMasc) & IIf(Bi > 0, IIf(Bi > 1, " bilhões", " bilhão"), "")

   f = f & IIf(VirgEntrMilh And Bi > 0 And Mõ > 0, ", ", IIf(Bi > 0 And Mõ > 0, " ", ""))
   f = f & IIf(ConjExc And Bi > 0 And Mõ > 0 And (Mõ < 100 Or Right(Mõ, 2) = "00"), "e ", "")

   f = f & fMilharText(Mõ, UndMasc) & IIf(Mõ > 0, IIf(Mõ > 1, " milhões", " milhão"), "")

   f = f & IIf(VirgEntrMilh And Bi + Mõ > 0 And Ma > 0, ", ", IIf(Bi + Mõ > 0 And Ma > 0, " ", ""))
   f = f & IIf(ConjExc And Bi + Mõ > 0 And Ma > 0 And (Ma < 100 Or Right(Ma, 2) = "00"), "e ", "")

   f = f & fMilharText(Ma, UndMasc) & IIf(Ma > 0, IIf(Ma > 1, " mil", " mil"), "")
   If Not UmMil Then If f = "um mil" Then f = "mil"  'Omitir 'um' em 'um mil'

   f = f & IIf(VirgEntrMilh And Bi + Mõ + Ma > 0 And Ce > 0, ", ", IIf(Bi + Mõ + Ma > 0 And Ce > 0, " ", ""))
   f = f & IIf(ConjExc And Bi + Mõ + Ma > 0 And Ce > 0 And (Ce < 100 Or Right(Ce, 2) = "00"), "e ", "")

   f = f & fMilharText(Ce, UndMasc) & IIf(Ce > 0, ",", "")

   f = IIf(Right(f, 1) = ",", Mid(f, 1, Len(f) - 1), f)
   f = IIf(Right(f, 2) = "ão", f & " de", f)
   f = IIf(Right(f, 3) = "ões", f & " de", f)
   fExtensoInt = f
End Function

Private Function fMilharText(NumText As String, UndMasc As Boolean)
'Gramática portuguesa:
'Regra Geral: Intercala-se a conjunção 'e' entre centenas, dezenas e unidades

   Dim UndText As String
   Dim DezenaText As String
   Dim CentenaText As String
   Const ConjDez_Un = " e "   'Conjunção entre Dezena e Unidade
   Const ConjCen_Dez = " e "   'Conjunção entre Centena e Unidade

   '  Unidade texto
   If Mid(NumText, 2, 1) <> "1" Then
      UndText = Choose(Mid(NumText, 3, 1) + 1, "", IIf(UndMasc, "um", "uma"), _
            IIf(UndMasc, "dois", "duas"), "três", "quatro", "cinco", "seis", _
            "sete", "oito", "nove")
   Else
      UndText = ""
   End If

   'Dezena texto
   If Mid(NumText, 2, 1) <> "1" Then
      DezenaText = Choose(Mid(NumText, 2, 1) + 1, "", "dez", "vinte", _
            "trinta", "quarenta", "cinqüenta", "sessenta", "setenta", _
            "oitenta", "noventa")
   Else
      DezenaText = Choose(Mid(NumText, 3, 1) + 1, "dez", "onze", _
            "doze", "treze", "quatorze", "quinze", "dezesseis", _
            "dezessete", "dezoito", "dezenove")
   End If

   'Centena texto
   If UndMasc Then
      CentenaText = Choose(Mid(NumText, 1, 1) + 1, "", "cento", "duzentos", _
            "trezentos", "quatrocentos", "quinhentos", "seiscentos", _
            "setecentos", "oitocentos", "novecentos")
   Else
      CentenaText = Choose(Mid(NumText, 1, 1) + 1, "", "cento", "duzentas", _
            "trezentas", "quatrocentas", "quinhentas", "seiscentas", _
            "setecentas", "oitocentas", "novecentas")
   End If
   If Mid(NumText, 1, 1) = "1" And Mid(NumText, 2, 2) = "00" Then CentenaText = "cem"

   'Milhar texto
   fMilharText = CentenaText & IIf(Mid(NumText, 2, 2) * 1 > 0 And CentenaText <> "", ConjCen_Dez, "") _
         & DezenaText & IIf(Mid(NumText, 2, 2) * 1 <= 19 Or Right(NumText, 1) = "0", "", ConjDez_Un) _
         & UndText
End Function

Function Pluralizar(Sing As String) As String
   Dim e As String

   Dim IsLCase As Boolean

   IsLCase = Right(Sing, 1) = LCase(Right(Sing, 1))

   'Regra geral:
   Pluralizar = IIf(Sing = "", "", Sing & IIf(IsLCase, "s", "S"))

   'Exceções: (Quase todas)
   ' Nomes terminados em al, el, ol, ul, il
   e = LCase(Right(Sing, 2))
   If e = "al" Or e = "el" Or e = "ol" Or e = "ul" Or e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 1) & IIf(IsLCase, "is", "IS")
   'Nomes terminados em il
   If e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 2) & IIf(IsLCase, "is", "IS")
   ' Nomes terminados em r, s, z
   e = LCase(Right(Sing, 1))
   If e = "r" Or e = "s" Or e = "z" Then Pluralizar = Sing & IIf(IsLCase, "es", "ES")
   ' Nomes terminados em m
   If e = "m" Then Pluralizar = Left(Sing, Len(Sing) - 1) & IIf(IsLCase, "ns", "NS")
   ' Nomes terminados em x
   If e = "x" Then Pluralizar = Sing
End Function

Private Function MyReplace(vText As String, vTxtFind As String, vTxtRep As String)
'Word 6.0 VBA doesn't have Replace function
    Dim lPos As Long
    lPos = 1 - Len(vTxtRep)
vStart:
    lPos = InStr(lPos + Len(vTxtRep), vText, vTxtFind)
    If lPos = 0 Or vTxtFind = "" Then
        MyReplace = vText
        Exit Function
    End If
    vText = Left(vText, lPos - 1) & vTxtRep & Right(vText, Len(vText) - lPos - Len(vTxtFind) + 1)
    GoTo vStart
End Function

---

Mode of use:

In the cell where you want the full value, type the following formula:

=fExtenso(A1; 1; "real"; "reais"), where:

• A1 - cell name with the value to be transcribed;
• 1 - Read a fraction in cents;
• "real" - name of the monetary unit in the singular;
• "reais" - name of the plural currency unit;