Função valor em extenso para excel

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.

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

'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 "

'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

'Processa cada grupo
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

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 intTamanho = 1 Then
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

End Function