Abra o excel, entre no editor do VBA alt + f11, insira um módulo e copie o
código abaixo. Após feito isso, feche o editor do VBA e insira a função
"extenso" em uma célula da sua planilha. A partir dai é só inserir os números e
você terá o escrito do valor digitado.
código abaixo. Após feito isso, feche o editor do VBA e insira a função
"extenso" em uma célula da sua planilha. A partir dai é só inserir os números e
você terá o escrito do valor digitado.
Function extenso(nValor As String) As String
If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function
'Declara as variáveis da função
Dim intContador As Integer
Dim
intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As
String
Dim intContador As Integer
Dim
intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As
String
'Define matrizes com extensos parciais
Dim strUnid(19) As String
strUnid(1) = "um ": strUnid(2) = "dois ": strUnid(3) = "três ": strUnid(4) =
"quatro ": strUnid(5) = "cinco ": strUnid(6) = "seis ": strUnid(7) = "sete ":
strUnid(8) = "oito ": strUnid(9) = "nove ": strUnid(10) = "dez ": strUnid(11) =
"onze ": strUnid(12) = "doze ": strUnid(13) = "treze ": strUnid(14) = "quatorze
": strUnid(15) = "quinze ": strUnid(16) = "dezesseis ": strUnid(17) = "dezessete
": strUnid(18) = "dezoito ": strUnid(19) = "dezenove "
Dim strDezena(9) As
String
strDezena(1) = "dez ": strDezena(2) = "vinte ": strDezena(3) =
"trinta ": strDezena(4) = "quarenta ": strDezena(5) = "cinqüenta ": strDezena(6)
= "sessenta ": strDezena(7) = "setenta ": strDezena(8) = "oitenta ":
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) =
"cento ": strCentena(2) = "duzentos ": strCentena(3) = "trezentos ":
strCentena(4) = "quatrocentos ": strCentena(5) = "quinhentos ": strCentena(6) =
"seiscentos ": strCentena(7) = "setecentos ": strCentena(8) = "oitocentos ":
strCentena(9) = "novecentos "
Dim strUnid(19) As String
strUnid(1) = "um ": strUnid(2) = "dois ": strUnid(3) = "três ": strUnid(4) =
"quatro ": strUnid(5) = "cinco ": strUnid(6) = "seis ": strUnid(7) = "sete ":
strUnid(8) = "oito ": strUnid(9) = "nove ": strUnid(10) = "dez ": strUnid(11) =
"onze ": strUnid(12) = "doze ": strUnid(13) = "treze ": strUnid(14) = "quatorze
": strUnid(15) = "quinze ": strUnid(16) = "dezesseis ": strUnid(17) = "dezessete
": strUnid(18) = "dezoito ": strUnid(19) = "dezenove "
Dim strDezena(9) As
String
strDezena(1) = "dez ": strDezena(2) = "vinte ": strDezena(3) =
"trinta ": strDezena(4) = "quarenta ": strDezena(5) = "cinqüenta ": strDezena(6)
= "sessenta ": strDezena(7) = "setenta ": strDezena(8) = "oitenta ":
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) =
"cento ": strCentena(2) = "duzentos ": strCentena(3) = "trezentos ":
strCentena(4) = "quatrocentos ": strCentena(5) = "quinhentos ": strCentena(6) =
"seiscentos ": strCentena(7) = "setecentos ": strCentena(8) = "oitocentos ":
strCentena(9) = "novecentos "
'Divide o valor em vários grupos
strValor = Format$(nValor,
"0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2)
= Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
strValor = Format$(nValor,
"0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2)
= Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
'Processa cada grupo
For intContador = 1 To 4
strParte =
strGrupo(intContador)
For intContador = 1 To 4
strParte =
strGrupo(intContador)
intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2,
Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte,
2) <> "00" Then
strTexto(intContador) = strTexto(intContador) +
strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) =
"1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte,
2) <> "00" Then
strTexto(intContador) = strTexto(intContador) +
strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) =
"1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) +
strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) +
strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) +
strUnid(Right(strParte, 1))
End If
Next intContador
strTexto(intContador) = strTexto(intContador) +
strUnid(Right(strParte, 1))
End If
Next intContador
'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) +
strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4)
+ IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0
Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) +
IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If
Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0
Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) +
IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If
Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0
Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) +
IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If
Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4))
= 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1)
+ IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If
Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4))
<> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0,
strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End
If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And
Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1))
<> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "),
"")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And
Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1))
<> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de
"), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0
And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal +
IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1,
"milhões, ", "milhão, "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ",
"")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal +
IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil,
", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal =
strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1,
"real ", "reais ")
Else
strFinal = strFinal + strTexto(3) +
IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) +
strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal =
strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) +
IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Left(strFinal, 1) = "u" Then
extenso = "H" &
Mid$(strFinal, 1)
Else
extenso = UCase(Mid$(strFinal, 1,
1)) & Mid$(strFinal, 2)
End If
Dim aux As String
* 150
aux = Trim(extenso) ' e alterar esta
linha para trim(extenso)
While Len(Trim(aux)) <> 150
aux =
Trim(aux) & "-$"
Wend
extenso = aux
If Val(strGrupo(1) + strGrupo(2) +
strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4)
+ IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0
Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) +
IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If
Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0
Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) +
IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If
Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0
Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) +
IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If
Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4))
= 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1)
+ IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If
Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4))
<> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0,
strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End
If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And
Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1))
<> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "),
"")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And
Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1))
<> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de
"), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0
And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal +
IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1,
"milhões, ", "milhão, "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ",
"")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal +
IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil,
", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal =
strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1,
"real ", "reais ")
Else
strFinal = strFinal + strTexto(3) +
IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) +
strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal =
strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) +
IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Left(strFinal, 1) = "u" Then
extenso = "H" &
Mid$(strFinal, 1)
Else
extenso = UCase(Mid$(strFinal, 1,
1)) & Mid$(strFinal, 2)
End If
Dim aux As String
* 150
aux = Trim(extenso) ' e alterar esta
linha para trim(extenso)
While Len(Trim(aux)) <> 150
aux =
Trim(aux) & "-$"
Wend
extenso = aux
End Function
3 comentários:
não consegui, deu erro
erro de compilação:
Erro de sintaxe
microsoft Visual Basic
wagner@kazums.com.br
excelente ... obrigado
Não consegui. Deu erro de compilação.
paulo_sergio0110@yahoo.com.br
Postar um comentário