Achei o primeiro campo que você se referiu desnecessário.
Utilize o código abaixo e execute o subprocedimento fMain:
Sub fMain()
Dim str As String
str = InputBox("Digite o valor do número")
If Not IsNumeric(str) Or str = "" Then Exit Sub
If str < 0 Then Exit Sub
Selection.TypeText Format(str, "R$ #,##0.00") _
& " (" & Extenso(CDbl(str)) & ")"
End Sub
Function Extenso(dValor As Double) As String
Dim sMoeda As String
Dim dCents As Variant
'Se o valor for igual ou maior que 1 quatrilhão
'não será possível proceder com a função
If dValor > 999999999999999# Then
Extenso = "valor muito grande"
Exit Function
End If
'Se o valor for menor que 1 centavo, considerar-se-á zero para a função:
If dValor < 0.01 Then
Extenso = "zero reais"
Exit Function
End If
'Se o valor da unidade for igual a 1, a unidade está no singular
'Caso contrário, estará no plural.
If Fix(dValor) = 1 Then
sMoeda = " real"
Else
sMoeda = " reais"
End If
'Remove os centavos
dCents = dValor - Fix(dValor)
'Remove os centavos do valor
dValor = dValor - CDbl(dCents)
'Chamar função de extenso para os centavos
dCents = Centavos(CDbl(dCents) * 100)
'Caso a string seja diferente de branco e valor seja maior ou igual a 1
If dCents <> vbNullString And dValor >= 1 Then
'acrescentar uma vírgula antes do extenso
dCents = " e " & dCents
End If
'Iniciar o processo de conversao dos valores longos
sMoeda = Trim(Trilhões(dValor)) & sMoeda & dCents
sMoeda = Replace(sMoeda, ", e", " e")
sMoeda = Replace(sMoeda, ", r", " r")
If Left(sMoeda, 2) = "e " Then
sMoeda = Mid(sMoeda, 3, Len(sMoeda))
'ElseIf Left(sMoeda, 5) = "mil e" Then
'sMoeda = Mid(sMoeda, 5, Len(sMoeda))
End If
Extenso = sMoeda
End Function
Private Function Centavos(dValor As Double) As String
'Passa o valor para base decimal
dValor = Round(CDbl(dValor / 100), 2)
'Se for um centavo, escrever valor e sair da função
If dValor = 0.01 Then
Centavos = "um centavo"
Exit Function
End If
'Repassa valor para dezenas
dValor = dValor * 100
'Se nao houver dezenas no valor passado
If Dezenas(dValor) = vbNullString Then
'a string centavos fica em branco
Centavos = vbNullString
Else
'caso contrário, passar extenso das dezenas e concatenar
'com a palavra centavos
Centavos = Dezenas(dValor) & " centavos"
End If
End Function
Private Function Unidades(dValor As Double) As String
Dim Unid(9) As String
'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 função:
Unidades = Unid(dValor)
End Function
Private Function Dezenas(dValor As Double) As String
Dim Dez1(9) As String
Dim Dez2(9) As String
Dim dDezena As Double
Dim dUnidade As Double
'Define as dezenas a serem utilizadas
Dez2(1) = "onze": Dez2(6) = "dezesseis"
Dez2(2) = "doze": Dez2(7) = "dezessete"
Dez2(3) = "treze": Dez2(8) = "dezoito"
Dez2(4) = "quatorze": Dez2(9) = "dezenove"
Dez2(5) = "quinze"
Dez1(1) = "dez": Dez1(6) = "sessenta"
Dez1(2) = "vinte": Dez1(7) = "setenta"
Dez1(3) = "trinta": Dez1(8) = "oitenta"
Dez1(4) = "quarenta": Dez1(9) = "noventa"
Dez1(5) = "cinquenta"
'Calcula o inteiro da dezena
dDezena = Fix(dValor / 10)
'Calcula o inteiro da unidade
dUnidade = dValor Mod 10
'Se o inteiro da dezena for zero
If dDezena = 0 Then
'dezenas sao iguais as unidades
Dezenas = Unidades(dUnidade)
Exit Function
Else
'caso contrário, é igual a dez
Dezenas = Dez1(dDezena)
End If
'Se o inteiro da dezena for igual a 1 e
'o inteiro da unidade for zero, os valores estão
'entre 11 e 19
If (dDezena = 1 And dUnidade > 0) Then
Dezenas = Dez2(dUnidade)
Else
'Caso contrário, valor está entre 20 e 90 inclusive
If (dDezena > 1 And dUnidade > 0) Then
'Concatena a string da dezena com a string da unidade
Dezenas = Dezenas & " e " & Unidades(dUnidade)
End If
End If
End Function
Private Function Centenas(dValor As Double) As String
Dim dCento As Double
Dim dDez As Double
Dim dUni As Double
Dim dUniMod As Double
Dim dModDez As Double
Dim sCento As String
Dim Cento(9) As String
'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
dCento = Fix(dValor / 100)
'Calcula a parte da dezena
dDez = dValor - (dCento * 100)
'Calcula o inteiro da unidade
dUni = Fix(dDez / 10)
'Calcula o resto da unidade
dUniMod = dUni Mod 10
'Calcula o resto da dezena
dModDez = dDez Mod 10
'Se centena for cem, definir string como "cem " e sair
If dValor = 100 Then
sCento = "cem "
Else
'Caso contrário definir a string da centena
sCento = Cento(dCento)
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, adicionar " e " à string da centena:
If (dUni >= 0 And dUniMod >= 0 And dDez >= 1 And dCento >= 1) Then
sCento = sCento & " e "
End If
'Concatena a string do cento com a string da dezena
Centenas = Trim(sCento & Dezenas(dDez))
End Function
Private Function Milhares(dValor As Double) As String
Dim dMilhar As Double
Dim dCento As Double
Dim sMilhar As String
'Calcula o inteiro da milhar
dMilhar = Fix(dValor / 1000)
'Calcula o cento dentro da milhar
dCento = dValor - (dMilhar * 1000)
'Se milhar for zero, entao a string da milhar fica em branco
If dMilhar = 0 Then sMilhar = vbNullString
If (dMilhar >= 1 And dMilhar < 10) Then
sMilhar = Unidades(dMilhar) & " mil, "
'Se for entre 10 e 100, então string igual a dezenas
ElseIf (dMilhar >= 10 And dMilhar < 100) Then
sMilhar = Dezenas(dMilhar) & " mil, "
'Se for entre 100 e 1000, então igual string centenas
ElseIf (dMilhar >= 100 And dMilhar < 1000) Then
sMilhar = Centenas(dMilhar) & " mil, "
End If
If (dCento >= 1 And dCento <= 100) Then sMilhar = sMilhar & "e "
Milhares = Trim(sMilhar & Centenas(dCento))
End Function
Private Function Milhões(dValor As Double) As String
'Mesma lógica usada pela rotina Milhares
Dim dMilhão As Double
Dim dMilhares As Double
Dim sMilhão As String
dMilhão = Int(dValor / 1000000)
dMilhares = dValor - (dMilhão * 1000000)
If dMilhão = 0 Then sMilhão = vbNullString
If (dMilhão = 1) Then
sMilhão = Unidades(dMilhão) & " milhão, "
ElseIf (dMilhão > 1 And dMilhão < 10) Then
sMilhão = Unidades(dMilhão) & " milhões, "
ElseIf (dMilhão >= 10 And dMilhão < 100) Then
sMilhão = Dezenas(dMilhão) & " milhões, "
ElseIf (dMilhão >= 100 And dMilhão < 1000) Then
sMilhão = Centenas(dMilhão) & " milhões, "
End If
If dValor = 1000000# Then sMilhão = "um milhão de "
Milhões = Trim(sMilhão & Milhares(dMilhares))
End Function
Private Function Bilhões(dValor As Double) As String
'Mesma lógica usada pela rotina Milhares
Dim dBilhão As Double
Dim dMilhão As Double
Dim sBilhão As String
dBilhão = Int(dValor / 1000000000)
dMilhão = dValor - (dBilhão * 1000000000)
If (dBilhão = 1) Then
sBilhão = Unidades(dBilhão) & " bilhão, "
ElseIf (dBilhão > 1 And dBilhão < 10) Then
sBilhão = Unidades(dBilhão) & " bilhões, "
ElseIf (dBilhão >= 10 And dBilhão < 100) Then
sBilhão = Dezenas(dBilhão) & " bilhões, "
ElseIf (dBilhão >= 100 And dBilhão < 1000) Then
sBilhão = Centenas(dBilhão) & " bilhões, "
End If
If dValor = 1000000000# Then sBilhão = "um bilhão de "
Bilhões = Trim(sBilhão & Milhões(dMilhão))
End Function
Private Function Trilhões(dValor As Double) As String
'Mesma lógica usada pela rotina Milhares
Dim dTrilhão As Double
Dim dBilhão As Double
Dim sTrilhão As String
dTrilhão = Int(dValor / 1000000000000#)
dBilhão = dValor - (dTrilhão * 1000000000000#)
If (dTrilhão = 1) Then
sTrilhão = Unidades(dTrilhão) & " trilhão, "
ElseIf (dTrilhão > 1 And dTrilhão < 10) Then
sTrilhão = Unidades(dTrilhão) & " trilhões, "
ElseIf (dTrilhão >= 10 And dTrilhão < 100) Then
sTrilhão = Dezenas(dTrilhão) & " trilhões, "
ElseIf (dTrilhão >= 100 And dTrilhão < 1000) Then
sTrilhão = Centenas(dTrilhão) & " trilhões, "
End If
If dValor = 1000000000000# Then sTrilhão = "um trilhão de "
Trilhões = Trim(sTrilhão & Bilhões(dBilhão))
End Function
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
