sábado, 27 de fevereiro de 2016

Função escrever por extenso no excel



Neste artigo você vai aprender a inserir uma função que vai escrever por extenso no excel

    O microsoft excel em todas as suas versões é repleto de funções, porém muitas vezes nos deparamos com situações onde as mesmas não não atendem nossa necessidade.
    Para contornar esta situação temos o nosso velho a amigo de sempre o VBA (Visual Basic for Applications), o VBA nos permite criar funções que não existem no excel, e neste artigos vamos ensinar a você a adicionar a função "fExtenso" esta função transforma o conteúdo de uma célula com números em texto (número por extenso).

Siga os passos abaixo.


Abra um novo documento do excel.



Abra o editor do Visual Basic (Alt F11).


Insira um módulo


Cole o código abaixo em um módulo.
---------------------------------------------------CODIGO-----------------------------------------------------------




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", "CINQUENTA", "SESSENTA", "SETENTA", _
            "OITENTA", "NOVENTA")
   Else
      DezenaText = Choose(Mid(NumText, 3, 1) + 1, "DEZ", "ONZE", _
            "DOSE", "TREZE", "QUATORZE", "QUINZE", "DEZESEIS", _
            "DEZESSETE", "DESOITO", "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

---------------------------------------------------------FIM------------------------------------------------------------




Va para a pasta de trabalho, digite em uma célula um valor e em outra a função.




Na função insira as seguintes informações.



Pronto ficará assim.



Aí você me pergunta, -Esta função vai aparecer em qualquer arquivo do excel que eu abrir?
A resposta é sim e não.

  • Não: até aqui vai aparecer apenas nesta pasta de trabalho.
  • Sim: para aparecer em qualquer pasta de trabalho basta salvar esta pasta e colocar nos suplementos.
Isso veremos no próximo artigo.


Colabore com o nosso trabalho, compartilhe este conteúdo com seus amigos eles também merecem este conhecimento.
Se você gostou deste artigo click em Gostei!


Veja tambem
Aprenda como exportar planilha do excel para PDF


Até o próximo artigo.

Grande Abraço!


EmoticonEmoticon