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
Veja tambem
Aprenda como exportar planilha do excel para PDF
Até o próximo artigo.
Grande Abraço!
EmoticonEmoticon