O excel não tem uma função para escrever numero por Extenso? não tinha...
Copie estes códigos abaixo, clique Alt+F11, vai em inserir, modulo, cole os códigos, clique F11, feche o editor VBA, no excel digite a função =Extenso. Selecione a célula contendo o número e pronto, os trechos que contem ' significa comentário.
'Rotinas que processam um numero até 999.999.999,99 '
'e retorna-o em extenso '
'Real e centavos '
Dim um_a_19
Dim dezenas
Dim centenas
Sub carregaVars()
um_a_19 = Array("", "um", "dois", "três", "quatro", "cinco", _
"seis", "sete", "oito", "nove", "dez", _
"onze", "doze", "treze", "quatorze", _
"quinze", "dezasseis", "dezassete", _
"dezoito", "dezanove")
dezenas = Array("", "dez", _
"vinte", "trinta", "quarenta", "cinquenta", _
"sessenta", "setenta", "oitenta", "noventa")
centenas = Array("cem", "cento", "duzentos", "trezentos", "quatrocentos", _
"quinhentos", "seiscentos", "setecentos", _
"oitocentos", "novecentos")
End Sub
Function Extenso(numero As Double) As String
Dim ExtensoTemp As String
Dim XMilhoes, XMilhares, XCentenas, Centavos
Call carregaVars
If numero > 999999999.99 Then
Extenso = "Erro - valor superior ao maximo:999.999.999,99"
Exit Function
End If
num = Format(numero, "000000000.00")
XMilhoes = Processa(Mid(num, 1, 3))
XMilhares = Processa(Mid(num, 4, 3))
XCentenas = Processa(Mid(num, 7, 3))
Centavos = Right(num, 2)
Select Case Centavos
Case Is <= 19
extCentavos = um_a_19(Centavos)
Case Is >= 20
extCentavos = dezenas(Left(Centavos, 1)) & " " & um_a_19(Right(Centavos, 1))
End Select
If XMilhoes > "" Then
If XMilhoes = "um" Then
ExtensoTemp = ExtensoTemp & XMilhoes & " milhão "
Else
ExtensoTemp = ExtensoTemp & XMilhoes & " milhões "
End If
End If
If XMilhares > "" Then
If XMilhares = "um" And XMilhoes = "" Then
ExtensoTemp = ExtensoTemp & "mil "
Else
ExtensoTemp = ExtensoTemp & XMilhares & " mil "
End If
End If
If XCentenas > "" Then ExtensoTemp = ExtensoTemp & XCentenas
If extCentavos > "" Then
ExtensoTemp = ExtensoTemp & " Real e " & extCentavos & " centavos"
Else
ExtensoTemp = ExtensoTemp & " Reais"
End If
Extenso = UCase(ExtensoTemp)
End Function
Function Processa(num) As String
'Rotina utilizada para processar
'parcelas de um numero
'dividido em três posições
Dim n
n = Format(num, "000")
a1 = Val(Mid(n, 1, 1))
a2 = Val(Mid(n, 2, 1))
a3 = Val(Mid(n, 3, 1))
If a1 <> 0 And a2 & a3 = "00" Then
If Val(a1 & a2 & a3) > 100 Then
Processa = centenas(a1)
Else
Processa = centenas(a1 - 1)
End If
ElseIf a1 > 0 And a2 >= 0 Then
Select Case a3
Case Is > 0
If Val(a2 & a3) > 19 Then
Processa = centenas(a1) & " e " & _
dezenas(a2) & " e " & _
um_a_19(a3)
Else
Processa = centenas(a1) & " e " & _
um_a_19(Val(a2 & a3))
End If
Case Is = 0
Processa = centenas(a1) & " e " & dezenas(a2)
End Select
ElseIf a1 = 0 Then
Select Case Val(a2 & a3)
Case Is < 20
Processa = um_a_19(Val(a2 & a3))
Case Else
If um_a_19(a3) = "" Then
Processa = dezenas(a2)
Else
Processa = dezenas(a2) & " e " & _
um_a_19(a3)
End If
End Select
Else
Processa = ""
End If
End Function
Nenhum comentário:
Postar um comentário