Número por Extenso Excel

Propaganda do Novo Office 2010 – Cool
24 de julho de 2010
Função de Conversão de Data Excel
25 de julho de 2010

Utilização da Função

Número por Extenso no Excel

Encontrei esta função, que apesar de antiga (2002) é muito útil. Ela escreve qualquer número por extenso bastando para isso apontar a célula.

Para utilizá-la basta seguir o post, de criar funções próprias globais e incluir esta função.

Utilização da Função

Utilização da Função – Clique para ampliar

Na figura acima, utilizei o código =PRI.MAIÚSCULA(fextenso(B2)), para que a primeira letra de cada palavra ficasse maiúscula.

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 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  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õ  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  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  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

Então é isso, agradeço a sua visita, e buscarei sempre incluir algo que pode ser usado no dia-a-dia na empresa para melhorar os processos já realizados.

Enviem dúvidas e sugestões, elas serão respondidas no blog.

Rieper

Veja este artigo em inglês: http://think-excel.com/convert-numbers-text-excel-extensive-number-excel/


Clique aqui e leia mais sobre Excel VBA. https://www.guiadoexcel.com.br/vba/ O Guia do Excel foi criado por Marcos Rieper e oferece artigos, dicas, tutoriais e modelos de planilhas prontas. Aqui você encontra tudo sobre Excel, seja de nível básico, intermediário,  avançado e VBA. O Guia do Excel oferece diversos materiais completamente gratuitos para download. Navegue em nosso site e confira! Conheça também a nossa Loja do Excel https://loja.guiadoexcel.com.br/
Cursos

Curso Excel Completo – Curso Excel Básico + Curso Excel Avançado – Acesso Vitalício

R$218,00 R$179,00

COMPRAR
Cursos

Curso Excel Master – Curso Excel Básico + Curso Excel Avançado + Curso VBA Excel + LP – Acesso Vitalício

R$357,00 R$249,00

COMPRAR
Cursos

Curso Excel PRO – Curso Excel Avançado + Curso VBA Excel + Lógica de programação – Acesso Vitalício

R$258,00 R$199,00

COMPRAR
Cursos

Curso Excel Web – Curso VBA Excel + Lógica de programação + Curso Web Scraping VBA- Acesso Vitalício

R$388,90 R$309,00

COMPRAR

17 Comentários

  1. THAYS disse:

    APOS SALVAR O MODULO, FAÇO O CAMINHO: ICONE EXCEL>OPÇÕES>SUPLEMENTOS>SUPLEMENTOS DO EXCEL>IR>(ABRE JANELA PARA CRIAÇÃO DOS SUPLEMENTOS)- APARECE OS DISPONIVEIS> CLICO EM PROCURAR E SELECIONO O ARQUIVO QUE CRIEI EM MODULO.
    DAI PRA FRENTE NÃO CONSIGO INSERIR A FUNCAO.
    PRECISO DE AJUDA!!!
    UGENTEMEENTE.
    APROVEITO AINDA PARA EXPRESSAR MINHA GRATIDÃO!
    VC’S SÃO PERFEITOS NO QUESITO EXCEL.
    O SITE É MARAVILHOSO..UM VERDADEIRO CURSO ONLINE DE EXCEL.
    DESDE JÁ GRATA!

  2. Marcos Rieper disse:

    Olá Thays,

    Pelo que entendi você conseguiu marcar o suplemento que você criou certo?

    Julgando que o suplemento já esteja com a função fExtenso, basta você escrever ela no excel =fExtenso(A2) ou =fExtenso(10).

    Se ainda não funcionar por favor me avise que vou buscar ajudá-la.

    Abraço

    Marcos Rieper

  3. THAYS disse:

    OK.
    TENTEI E NÃO DEU CERTO..
    HÁ UM EMAIL ONDE EU POSSA LHE ENVIAR UM PRINT’S DA MENSAGEM QUE APARECE PARA MIM DE ERRO DE COMPLIÇÃO: ERRO DE SINTAXE..

    OH CEUUS!

  4. Monica disse:

    Consegui fazer por este site aqui http://tecnologia.uol.com.br/dicas/ultnot/2008/06/16/ult2665u343.jhtm e deu tudo certo.
    Estou usando para fazer cheques, só me ocorreu uma dúvida quanto ao preenchimento dos espaços vazios com asteriscos (Quinhentos Reais************).

    • Marcos Rieper disse:

      Boa tarde Mônica,

      Use a fórmula REPT em conjunto com esta.

      = MAIÚSCULA(fExtenso(I2;;”Real”;”Reais”;;;;0))&REPT(“*”;30-NÚM.CARACT(fExtenso(I2;;”Real”;”Reais”;;;;0)))

      Abraço

      Marcos Rieper

  5. […] See this post in portuguese: http://guiadoexcel.com.br/numero-por-extenso-excel […]

  6. […] See this post in portuguese: http://guiadoexcel.com.br/numero-por-extenso-excel […]

  7. Celso Torres disse:

    Olá, você conhece alguma função para escrever números de porcentagem por extenso?
    Por exemplo: 10,5%.
    Dez vírgula cinco porcento.
    Abraço e obrigado, suas dicas são excelentes.

  8. Consegui escrever um numero de até 999 milhões por extenso no excel, sem utilizar nenhuma VBA ou algo externo, só usando lógica e as funções procv(), mod() e se(). Funciona perfeitamente!

  9. valdir disse:

    Excelente função! Mas, o que deve ser alterado para números superiores a 1 trilhão, ao menos 1 quatrilhão? Obrigado.

  10. Cristiano disse:

    Fiz todo o processo e na hora de passar a formula da erro e mostra a seguinte mensagem: Erro de compilação End If sem bloco If.

    então abre a macro automaticamente e marca de amarelo está parte do inicio:

    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

  11. Jorge Cabral disse:

    Marcos, o código tem vários erros, que deve ser por causa do PASTE, pex. em ” If Num > 999999999999.99 Or Num =0 e < 1 trilhão)"
    Exit Function
    End If

    Mas tem mais, seria possível disponibilizar o ficheiro com o código? É que o link para a versão em Inglês tb não funciona. Obg

  12. adriano disse:

    Excelente funcao! So queria saber como posso fazer com que ela escreve por extenso no genero feminino.

Deixe uma resposta

O seu endereço de e-mail não será publicado. Campos obrigatórios são marcados com *

Esse site utiliza o Akismet para reduzir spam. Aprenda como seus dados de comentários são processados.

Inscreva-se no nosso canal do Youtube!


Junte-se ao nosso canal do Youtube. Começamos em abril de 2016, mas já temos mais de 06:00 h de treinamentos gratuitos e este número irá aumentar. Vídeos novos todos os sábados.