- 20 Fev 2022 às 20:37
#69268
Boa noite, estou com um problema na minha planilha.
Eu queria uma fórmula para escrever números por extenso, então eu peguei uma da internet, mas percebi alguns erros no código e eu não sei como resolver.
Quando o número é só milhar(exemplo: 1.000), ele escreve "um mil,", eu queria tirar essa vírgula nesse caso.
Quando é um número só com milhar e centena(exemplo: 1.500), ele escreve "um mil, quinhentos". eu queria trocar essa vírgula por um "e" nesse caso.
Alguém sabe me dizer o que pode ser feito?
Segue abaixo o código que eu peguei.
Function Extenso_Valor(valor As Double) As String
Dim strMoeda As String
Dim cents As Variant
Dim decimalSep As String
' Se o valor for igual ou maior que 1 quatrilhao
' passar erro e sair da funcao
If valor > 999999999999999# Then
Extenso_Valor = "Valor excede 999.999.999.999.999"
Exit Function
End If
' Se valor for igual a 1, a unidade est� no singular
If WorksheetFunction.RoundDown(valor, 0) = 1 Then
' a string da moeda no singular
strMoeda = " real"
' Se for maior que 1 a unidade est� no plural
ElseIf WorksheetFunction.RoundDown(valor, 0) > 1 Then
strMoeda = " reais"
End If
' Remove os centavos
cents = valor - WorksheetFunction.RoundDown(valor, 0)
' Remove os centavos do valor
valor = valor - CDbl(cents)
' Passo o extenso dos centavos
cents = centavos(CDbl(cents) * 100)
' End If
' Caso a string seja diferente de branco e valor seja maior ou igual a 1
If cents <> "" And valor >= 1 Then
' acrescentar uma v�rgula antes do extenso
cents = " e " & cents
End If
' Iniciar o processo de conversao dos valores longos
strMoeda = Trim(Trilhoes(valor)) & strMoeda & cents
strMoeda = Replace(strMoeda, ", e", " e")
strMoeda = Replace(strMoeda, ", r", " r")
If Left(strMoeda, 2) = "e " Then
strMoeda = Mid(strMoeda, 3, Len(strMoeda))
'ElseIf Left(strMoeda, 5) = "mil e" Then
' strMoeda = Mid(strMoeda, 5, Len(strMoeda))
End If
vzz = "00000000000000000000"
vtam = Len(Trim(Mid(Trim(valor), 2, 100)))
If Right(vzz + vzz + vzz + vzz, vtam) = Mid(Trim(valor), 2, 100) And InStr(UCase(strMoeda), UCase("es ")) > 0 Then
vetor = Split(strMoeda, " ")
vtrocar = vetor(UBound(vetor))
strMoeda = Replace(strMoeda, vtrocar, "de " + vtrocar)
End If
Extenso_Valor = strMoeda
End Function
Private Function centavos(valor As Double) As String
Dim dezena As Integer
Dim unidade As Integer
' Passa o valor para base decimal
valor = Round(CDbl(valor / 100), 2)
' Se for um centavo, escrever valor e sair da funcao
If valor = 0.01 Then
centavos = "um centavo"
Exit Function
End If
' Repassa valor para dezenas
valor = valor * 100
' Se nao houver dezenas no valor passado
If dezenas(valor) = "" Then
' a string centavos fica em branco
centavos = ""
Else
' caso contr�rio, passar extenso das dezenas e concatenar
' com a palavra centavos
centavos = dezenas(valor) & " centavos"
End If
End Function
Private Function unidades(unidade As Double) As String
Dim unid(9)
' Define as unidades a serem usadas
unid(1) = "um": unid(6) = "seis"
unid(2) = "dois": unid(7) = "sete"
unid(3) = "tr�s": unid(8) = "oito"
unid(4) = "quatro": unid(9) = "nove"
unid(5) = "cinco"
' Retorna a string referente a unidade passada para
' esta funcao
unidades = Trim(unid(unidade))
End Function
Private Function dezenas(dezena As Double) As String
Dim dezes(9)
Dim dez(9)
Dim intDezena As Double
Dim intUnidade As Double
Dim tmpStr As String
' Define as dezenas a serem utilizadas
dezes(1) = "onze": dezes(6) = "dezesseis"
dezes(2) = "doze": dezes(7) = "dezessete"
dezes(3) = "treze": dezes(8) = "dezoito"
dezes(4) = "quatorze": dezes(9) = "dezenove"
dezes(5) = "quinze"
dez(1) = "dez": dez(6) = "sessenta"
dez(2) = "vinte": dez(7) = "setenta"
dez(3) = "trinta": dez(8) = "oitenta"
dez(4) = "quarenta": dez(9) = "noventa"
dez(5) = "cinquenta"
' Calcula o inteiro da dezena
intDezena = Int(dezena / 10)
' Calcula o inteiro da unidade
intUnidade = dezena Mod 10
' Se o inteiro da dezena for zero
If intDezena = 0 Then
' dezenas sao iguais as unidades
dezenas = unidades(intUnidade)
Exit Function
Else:
' caso contr�rio, � igual a dez
dezenas = dez(intDezena)
End If
' Se o inteiro da dezena for igual a 1 e
' o inteiro da unidade for zero, os valores estao
' entre 11 e 19
If (intDezena = 1 And intUnidade > 0) Then
dezenas = dezes(intUnidade)
Else
' Caso contr�rio, valor est� entre 20 e 90 inclusive
If (intDezena > 1 And intUnidade > 0) Then
' Concatena a string da dezena com a string da unidade
dezenas = dezenas & " e " & unidades(intUnidade)
End If
End If
dezenas = dezenas
End Function
Private Function centenas(centena As Double) As String
Dim tmpCento As Double
Dim tmpDez As Double
Dim tmpUni As Double
Dim tmpUniMod As Double
Dim tmpModDez As Double
Dim centoString As String
Dim cento(9)
' Define as centenas
cento(1) = "cento": cento(6) = "seiscentos"
cento(2) = "duzentos": cento(7) = "setecentos"
cento(3) = "trezentos": cento(8) = "oitocentos"
cento(4) = "quatrocentos": cento(9) = "novecentos"
cento(5) = "quinhentos"
' Calcula o inteiro da centena
tmpCento = Int(centena / 100)
' Calcula a parte da dezena
tmpDez = centena - (tmpCento * 100)
' Calcula o inteiro da unidade
tmpUni = Int(tmpDez / 10)
' Calcula o resto da unidade
tmpUniMod = tmpUni Mod 10
' Calcula o resto da dezena
tmpModDez = tmpDez Mod 10
' Se centena for cem, definir string como "cem " e sair
If centena = 100 Then
centoString = "cem "
Else
' Caso contr�rio definir a string da centena
centoString = cento(tmpCento)
End If
' Avalia se a unidade � maior ou igual a zero, se o resto da unidade � igual ou
' maior que zero, se a dezena � maior ou igual a um e se a centena � igual ou
' maior que 1. Se forem verdadeiros; entao, adicionar " e " a string da centena
If (tmpUni >= 0 And tmpUniMod >= 0 And tmpDez >= 1 And tmpCento >= 1) Then
centoString = centoString & " e "
End If
' Concatena a string do cento com a string da dezena
centenas = Trim(centoString & dezenas(tmpDez))
End Function
Private Function milhares(milhar As Double) As String
Dim tmpMilhar As Double
Dim tmpCento As Double
Dim milString As String
' Calcula o inteiro da milhar
tmpMilhar = Int(milhar / 1000)
' Calcula o cento dentro da milhar
tmpCento = milhar - (tmpMilhar * 1000)
' Se milhar for zero, entao a string da milhar fica em branco
If tmpMilhar = 0 Then milString = ""
' Se for igual a 1, entao
' If '(tmpMilhar = 1) Then
' string da milhar � igual a unidade e "mil"
'milString = unidades(tmpMilhar) & "um mil "
' se maior que 1 e menor que dez, string igual a unidades
If (tmpMilhar >= 1 And tmpMilhar < 10) Then
milString = unidades(tmpMilhar) & " mil, "
' Se for entre 10 e 100, entao string igual a dezenas
ElseIf (tmpMilhar >= 10 And tmpMilhar < 100) Then
milString = dezenas(tmpMilhar) & " mil, "
' Se for entre 100 e 1000, entao igual string centenas
ElseIf (tmpMilhar >= 100 And tmpMilhar < 1000) Then
milString = centenas(tmpMilhar) & " mil, "
End If
'If tmpCento = 1 Then milString = " e "
If (tmpCento >= 1 And tmpCento <= 100) Then milString = milString & "e "
milhares = Trim(milString & centenas(tmpCento))
End Function
Private Function milhoes(milhao As Double) As String
' Ver coment�rios para milhares acima
Dim tmpMilhao As Double
Dim tmpMilhares As Double
Dim miString As String
tmpMilhao = Int(milhao / 1000000)
tmpMilhares = milhao - (tmpMilhao * 1000000)
If tmpMilhao = 0 Then miString = ""
If (tmpMilhao = 1) Then
miString = unidades(tmpMilhao) & " milh�o, "
ElseIf (tmpMilhao > 1 And tmpMilhao < 10) Then
miString = unidades(tmpMilhao) & " milh�es, "
ElseIf (tmpMilhao >= 10 And tmpMilhao < 100) Then
miString = dezenas(tmpMilhao) & " milh�es, "
ElseIf (tmpMilhao >= 100 And tmpMilhao < 1000) Then
miString = centenas(tmpMilhao) & " milh�es, "
End If
If milhao = 1000000# Then miString = "um milh�o de "
milhoes = Trim(miString & milhares(tmpMilhares))
End Function
Private Function bilhoes(bilhao As Double) As String
' Ver coment�rios para milhares acima
Dim tmpBilhao As Double
Dim tmpMilhao As Double
'Dim tmpMilhoes As Double
Dim biString As String
tmpBilhao = Int(bilhao / 1000000000)
tmpMilhao = bilhao - (tmpBilhao * 1000000000)
If (tmpBilhao = 1) Then
biString = unidades(tmpBilhao) & " bilh�o, "
ElseIf (tmpBilhao > 1 And tmpBilhao < 10) Then
biString = unidades(tmpBilhao) & " bilh�es, "
ElseIf (tmpBilhao >= 10 And tmpBilhao < 100) Then
biString = dezenas(tmpBilhao) & " bilh�es, "
ElseIf (tmpBilhao >= 100 And tmpBilhao < 1000) Then
biString = centenas(tmpBilhao) & " bilh�es, "
End If
If bilhao = 1000000000# Then biString = "um bilh�o de "
bilhoes = Trim(biString & milhoes(tmpMilhao))
End Function
Private Function Trilhoes(Trilhao As Double) As String
' Ver coment�rios para milhares acima
Dim tmpTrilhao As Double
Dim tmpBilhao As Double
Dim triString As String
tmpTrilhao = Int(Trilhao / 1000000000000#)
tmpBilhao = Trilhao - (tmpTrilhao * 1000000000000#)
If (tmpTrilhao = 1) Then
triString = unidades(tmpTrilhao) & " trilh�o, "
ElseIf (tmpTrilhao > 1 And tmpTrilhao < 10) Then
triString = unidades(tmpTrilhao) & " trilh�es, "
ElseIf (tmpTrilhao >= 10 And tmpTrilhao < 100) Then
triString = dezenas(tmpTrilhao) & " trilh�es, "
ElseIf (tmpTrilhao >= 100 And tmpTrilhao < 1000) Then
triString = centenas(tmpTrilhao) & " trilh�es, "
End If
If Trilhao = 1000000000000# Then triString = "um trilh�o de "
Trilhoes = Trim(triString & bilhoes(tmpBilhao))
End Function
Function arredBaixo(valor)
Dim tmpValor
tmpValor = Round(CDbl(Right(Round(valor, 2) * 100, 2)) / 100, 2)
arredBaixo = Round(Round(valor, 2) - tmpValor, 0)
End Function
Eu queria uma fórmula para escrever números por extenso, então eu peguei uma da internet, mas percebi alguns erros no código e eu não sei como resolver.
Quando o número é só milhar(exemplo: 1.000), ele escreve "um mil,", eu queria tirar essa vírgula nesse caso.
Quando é um número só com milhar e centena(exemplo: 1.500), ele escreve "um mil, quinhentos". eu queria trocar essa vírgula por um "e" nesse caso.
Alguém sabe me dizer o que pode ser feito?
Segue abaixo o código que eu peguei.
Function Extenso_Valor(valor As Double) As String
Dim strMoeda As String
Dim cents As Variant
Dim decimalSep As String
' Se o valor for igual ou maior que 1 quatrilhao
' passar erro e sair da funcao
If valor > 999999999999999# Then
Extenso_Valor = "Valor excede 999.999.999.999.999"
Exit Function
End If
' Se valor for igual a 1, a unidade est� no singular
If WorksheetFunction.RoundDown(valor, 0) = 1 Then
' a string da moeda no singular
strMoeda = " real"
' Se for maior que 1 a unidade est� no plural
ElseIf WorksheetFunction.RoundDown(valor, 0) > 1 Then
strMoeda = " reais"
End If
' Remove os centavos
cents = valor - WorksheetFunction.RoundDown(valor, 0)
' Remove os centavos do valor
valor = valor - CDbl(cents)
' Passo o extenso dos centavos
cents = centavos(CDbl(cents) * 100)
' End If
' Caso a string seja diferente de branco e valor seja maior ou igual a 1
If cents <> "" And valor >= 1 Then
' acrescentar uma v�rgula antes do extenso
cents = " e " & cents
End If
' Iniciar o processo de conversao dos valores longos
strMoeda = Trim(Trilhoes(valor)) & strMoeda & cents
strMoeda = Replace(strMoeda, ", e", " e")
strMoeda = Replace(strMoeda, ", r", " r")
If Left(strMoeda, 2) = "e " Then
strMoeda = Mid(strMoeda, 3, Len(strMoeda))
'ElseIf Left(strMoeda, 5) = "mil e" Then
' strMoeda = Mid(strMoeda, 5, Len(strMoeda))
End If
vzz = "00000000000000000000"
vtam = Len(Trim(Mid(Trim(valor), 2, 100)))
If Right(vzz + vzz + vzz + vzz, vtam) = Mid(Trim(valor), 2, 100) And InStr(UCase(strMoeda), UCase("es ")) > 0 Then
vetor = Split(strMoeda, " ")
vtrocar = vetor(UBound(vetor))
strMoeda = Replace(strMoeda, vtrocar, "de " + vtrocar)
End If
Extenso_Valor = strMoeda
End Function
Private Function centavos(valor As Double) As String
Dim dezena As Integer
Dim unidade As Integer
' Passa o valor para base decimal
valor = Round(CDbl(valor / 100), 2)
' Se for um centavo, escrever valor e sair da funcao
If valor = 0.01 Then
centavos = "um centavo"
Exit Function
End If
' Repassa valor para dezenas
valor = valor * 100
' Se nao houver dezenas no valor passado
If dezenas(valor) = "" Then
' a string centavos fica em branco
centavos = ""
Else
' caso contr�rio, passar extenso das dezenas e concatenar
' com a palavra centavos
centavos = dezenas(valor) & " centavos"
End If
End Function
Private Function unidades(unidade As Double) As String
Dim unid(9)
' Define as unidades a serem usadas
unid(1) = "um": unid(6) = "seis"
unid(2) = "dois": unid(7) = "sete"
unid(3) = "tr�s": unid(8) = "oito"
unid(4) = "quatro": unid(9) = "nove"
unid(5) = "cinco"
' Retorna a string referente a unidade passada para
' esta funcao
unidades = Trim(unid(unidade))
End Function
Private Function dezenas(dezena As Double) As String
Dim dezes(9)
Dim dez(9)
Dim intDezena As Double
Dim intUnidade As Double
Dim tmpStr As String
' Define as dezenas a serem utilizadas
dezes(1) = "onze": dezes(6) = "dezesseis"
dezes(2) = "doze": dezes(7) = "dezessete"
dezes(3) = "treze": dezes(8) = "dezoito"
dezes(4) = "quatorze": dezes(9) = "dezenove"
dezes(5) = "quinze"
dez(1) = "dez": dez(6) = "sessenta"
dez(2) = "vinte": dez(7) = "setenta"
dez(3) = "trinta": dez(8) = "oitenta"
dez(4) = "quarenta": dez(9) = "noventa"
dez(5) = "cinquenta"
' Calcula o inteiro da dezena
intDezena = Int(dezena / 10)
' Calcula o inteiro da unidade
intUnidade = dezena Mod 10
' Se o inteiro da dezena for zero
If intDezena = 0 Then
' dezenas sao iguais as unidades
dezenas = unidades(intUnidade)
Exit Function
Else:
' caso contr�rio, � igual a dez
dezenas = dez(intDezena)
End If
' Se o inteiro da dezena for igual a 1 e
' o inteiro da unidade for zero, os valores estao
' entre 11 e 19
If (intDezena = 1 And intUnidade > 0) Then
dezenas = dezes(intUnidade)
Else
' Caso contr�rio, valor est� entre 20 e 90 inclusive
If (intDezena > 1 And intUnidade > 0) Then
' Concatena a string da dezena com a string da unidade
dezenas = dezenas & " e " & unidades(intUnidade)
End If
End If
dezenas = dezenas
End Function
Private Function centenas(centena As Double) As String
Dim tmpCento As Double
Dim tmpDez As Double
Dim tmpUni As Double
Dim tmpUniMod As Double
Dim tmpModDez As Double
Dim centoString As String
Dim cento(9)
' Define as centenas
cento(1) = "cento": cento(6) = "seiscentos"
cento(2) = "duzentos": cento(7) = "setecentos"
cento(3) = "trezentos": cento(8) = "oitocentos"
cento(4) = "quatrocentos": cento(9) = "novecentos"
cento(5) = "quinhentos"
' Calcula o inteiro da centena
tmpCento = Int(centena / 100)
' Calcula a parte da dezena
tmpDez = centena - (tmpCento * 100)
' Calcula o inteiro da unidade
tmpUni = Int(tmpDez / 10)
' Calcula o resto da unidade
tmpUniMod = tmpUni Mod 10
' Calcula o resto da dezena
tmpModDez = tmpDez Mod 10
' Se centena for cem, definir string como "cem " e sair
If centena = 100 Then
centoString = "cem "
Else
' Caso contr�rio definir a string da centena
centoString = cento(tmpCento)
End If
' Avalia se a unidade � maior ou igual a zero, se o resto da unidade � igual ou
' maior que zero, se a dezena � maior ou igual a um e se a centena � igual ou
' maior que 1. Se forem verdadeiros; entao, adicionar " e " a string da centena
If (tmpUni >= 0 And tmpUniMod >= 0 And tmpDez >= 1 And tmpCento >= 1) Then
centoString = centoString & " e "
End If
' Concatena a string do cento com a string da dezena
centenas = Trim(centoString & dezenas(tmpDez))
End Function
Private Function milhares(milhar As Double) As String
Dim tmpMilhar As Double
Dim tmpCento As Double
Dim milString As String
' Calcula o inteiro da milhar
tmpMilhar = Int(milhar / 1000)
' Calcula o cento dentro da milhar
tmpCento = milhar - (tmpMilhar * 1000)
' Se milhar for zero, entao a string da milhar fica em branco
If tmpMilhar = 0 Then milString = ""
' Se for igual a 1, entao
' If '(tmpMilhar = 1) Then
' string da milhar � igual a unidade e "mil"
'milString = unidades(tmpMilhar) & "um mil "
' se maior que 1 e menor que dez, string igual a unidades
If (tmpMilhar >= 1 And tmpMilhar < 10) Then
milString = unidades(tmpMilhar) & " mil, "
' Se for entre 10 e 100, entao string igual a dezenas
ElseIf (tmpMilhar >= 10 And tmpMilhar < 100) Then
milString = dezenas(tmpMilhar) & " mil, "
' Se for entre 100 e 1000, entao igual string centenas
ElseIf (tmpMilhar >= 100 And tmpMilhar < 1000) Then
milString = centenas(tmpMilhar) & " mil, "
End If
'If tmpCento = 1 Then milString = " e "
If (tmpCento >= 1 And tmpCento <= 100) Then milString = milString & "e "
milhares = Trim(milString & centenas(tmpCento))
End Function
Private Function milhoes(milhao As Double) As String
' Ver coment�rios para milhares acima
Dim tmpMilhao As Double
Dim tmpMilhares As Double
Dim miString As String
tmpMilhao = Int(milhao / 1000000)
tmpMilhares = milhao - (tmpMilhao * 1000000)
If tmpMilhao = 0 Then miString = ""
If (tmpMilhao = 1) Then
miString = unidades(tmpMilhao) & " milh�o, "
ElseIf (tmpMilhao > 1 And tmpMilhao < 10) Then
miString = unidades(tmpMilhao) & " milh�es, "
ElseIf (tmpMilhao >= 10 And tmpMilhao < 100) Then
miString = dezenas(tmpMilhao) & " milh�es, "
ElseIf (tmpMilhao >= 100 And tmpMilhao < 1000) Then
miString = centenas(tmpMilhao) & " milh�es, "
End If
If milhao = 1000000# Then miString = "um milh�o de "
milhoes = Trim(miString & milhares(tmpMilhares))
End Function
Private Function bilhoes(bilhao As Double) As String
' Ver coment�rios para milhares acima
Dim tmpBilhao As Double
Dim tmpMilhao As Double
'Dim tmpMilhoes As Double
Dim biString As String
tmpBilhao = Int(bilhao / 1000000000)
tmpMilhao = bilhao - (tmpBilhao * 1000000000)
If (tmpBilhao = 1) Then
biString = unidades(tmpBilhao) & " bilh�o, "
ElseIf (tmpBilhao > 1 And tmpBilhao < 10) Then
biString = unidades(tmpBilhao) & " bilh�es, "
ElseIf (tmpBilhao >= 10 And tmpBilhao < 100) Then
biString = dezenas(tmpBilhao) & " bilh�es, "
ElseIf (tmpBilhao >= 100 And tmpBilhao < 1000) Then
biString = centenas(tmpBilhao) & " bilh�es, "
End If
If bilhao = 1000000000# Then biString = "um bilh�o de "
bilhoes = Trim(biString & milhoes(tmpMilhao))
End Function
Private Function Trilhoes(Trilhao As Double) As String
' Ver coment�rios para milhares acima
Dim tmpTrilhao As Double
Dim tmpBilhao As Double
Dim triString As String
tmpTrilhao = Int(Trilhao / 1000000000000#)
tmpBilhao = Trilhao - (tmpTrilhao * 1000000000000#)
If (tmpTrilhao = 1) Then
triString = unidades(tmpTrilhao) & " trilh�o, "
ElseIf (tmpTrilhao > 1 And tmpTrilhao < 10) Then
triString = unidades(tmpTrilhao) & " trilh�es, "
ElseIf (tmpTrilhao >= 10 And tmpTrilhao < 100) Then
triString = dezenas(tmpTrilhao) & " trilh�es, "
ElseIf (tmpTrilhao >= 100 And tmpTrilhao < 1000) Then
triString = centenas(tmpTrilhao) & " trilh�es, "
End If
If Trilhao = 1000000000000# Then triString = "um trilh�o de "
Trilhoes = Trim(triString & bilhoes(tmpBilhao))
End Function
Function arredBaixo(valor)
Dim tmpValor
tmpValor = Round(CDbl(Right(Round(valor, 2) * 100, 2)) / 100, 2)
arredBaixo = Round(Round(valor, 2) - tmpValor, 0)
End Function
