CODIGO PARA VALOR EM EXTENSO

Function Extenso(nValor)
'
'escreve o valor em Reais por extenso
'
'

'Faz a validação do argumento
If IsNull(nValor) Or nValor <= 0 Or nValor > 9999999.99 Then
Exit Function
End If

'Declara as variáveis da função
Dim nContador, nTamanho As Integer
Dim cValor, cParte, cFinal As String
ReDim aGrupo(4), aTexto(4) As String

'Define matrizes com extensos parciais
ReDim aUnid(19) As String
aUnid(1) = "Um ": aUnid(2) = "Dois ": aUnid(3) = "Três "
aUnid(4) = "Quatro ": aUnid(5) = "Cinco ": aUnid(6) = "Seis "
aUnid(7) = "Sete ": aUnid(8) = "Oito ": aUnid(9) = "Nove "
aUnid(10) = "Dez ": aUnid(11) = "Onze ": aUnid(12) = "Doze "
aUnid(13) = "Treze ": aUnid(14) = "Quatorze ": aUnid(15) = "Quinze "
aUnid(16) = "Dezesseis ": aUnid(17) = "Dezessete ": aUnid(18) = "Dezoito "
aUnid(19) = "Dezenove "

ReDim aDezena(9) As String
aDezena(1) = "Dez ": aDezena(2) = "Vinte ": aDezena(3) = "Trinta "
aDezena(4) = "Quarenta ": aDezena(5) = "Cinqüenta "
aDezena(6) = "Sessenta ": aDezena(7) = "Setenta ": aDezena(8) = "Oitenta "
aDezena(9) = "Noventa "

ReDim aCentena(9) As String
aCentena(1) = "Cento ": aCentena(2) = "Duzentos "
aCentena(3) = "Trezentos ": aCentena(4) = "Quatrocentos "
aCentena(5) = "Quinhentos ": aCentena(6) = "Seiscentos "
aCentena(7) = "Setecentos ": aCentena(8) = "Oitocentos "
aCentena(9) = "Novecentos "

'Divide o valor em vários grupos
cValor = Format$(nValor, "0000000000.00")
aGrupo(1) = Mid$(cValor, 2, 3)
aGrupo(2) = Mid$(cValor, 5, 3)
aGrupo(3) = Mid$(cValor, 8, 3)
aGrupo(4) = "0" + Mid$(cValor, 12, 2)

'Processa cada grupo
For nContador = 1 To 4
cParte = aGrupo(nContador)
nTamanho = Switch(Val(cParte) < 10, 1, Val(cParte) < 100, 2, Val(cParte) < 1000, 3) If nTamanho = 3 Then If Right$(cParte, 2) <> "00" Then
aTexto(nContador) = aTexto(nContador) + aCentena(Left(cParte, 1)) + "e "
nTamanho = 2
Else
aTexto(nContador) = aTexto(nContador) + IIf(Left$(cParte, 1) = "1", "Cem ", aCentena(Left(cParte, 1)))
End If
End If
If nTamanho = 2 Then
If Val(Right(cParte, 2)) < 20 Then aTexto(nContador) = aTexto(nContador) + aUnid(Right(cParte, 2)) Else: aTexto(nContador) = aTexto(nContador) + aDezena(Mid(cParte, 2, 1)) If Right$(cParte, 1) <> "0" Then
aTexto(nContador) = aTexto(nContador) + "e "
nTamanho = 1
End If
End If
End If
If nTamanho = 1 Then
aTexto(nContador) = aTexto(nContador) + aUnid(Right(cParte, 1))
End If
Next

'Gera o formato final do texto
If Val(aGrupo(1) + aGrupo(2) + aGrupo(3)) = 0 And Val(aGrupo(4)) <> 0 Then
cFinal = aTexto(4) + IIf(Val(aGrupo(4)) = 1, "Centavo", "Centavos")
Else
cFinal = ""
cFinal = cFinal + IIf(Val(aGrupo(1)) <> 0, aTexto(1) + IIf(Val(aGrupo(1)) > 1, "Milhões ", "Milhão "), "")
If Val(aGrupo(2) + aGrupo(3)) = 0 Then
cFinal = cFinal + "De "
Else
cFinal = cFinal + IIf(Val(aGrupo(2)) <> 0, aTexto(2) + "Mil ", "")
End If
cFinal = cFinal + aTexto(3) + IIf(Val(aGrupo(1) + aGrupo(2) + aGrupo(3)) = 1, "Real", "Reais ")
cFinal = cFinal + IIf(Val(aGrupo(4)) <> 0, "e " + aTexto(4) + IIf(Val(aGrupo(4)) = 1, "Centavo", "Centavos"), "")
End If
Extenso = cFinal

End Function

Posted in: CÓDIGOS, EXCEL