Nº Por Extenso

[Guest - Pedro -]

Senhores,

Gostaria de um algoritmo, se possível, pronto, ou uma função que me retorne o extenso de um número no excel. EX.: R$ 1.500,00 - A função retone "Hum mil e quinhentos reais)... Se possível é claro, ou algo semelhante.

Desde já agradeço a ajuda.

Pedro

[Guest Peregrino]

' Fonte (http://www.vbbrasil.com)

Function VExtenso(NValor)

On Error GoTo 99

If IsNull(NValor) Or NValor > 9999999 Then

VExtenso = "# VALOR POR EXTENSO..............."

Exit Function

End If

If (NValor) < 0 Then

NValor = NValor * -1

End If

Dim nContador, nTamanho As Integer

Dim CValor, CPArte, CFinal, Etiq As String

ReDim aGrupo(4), aTexto(4) As String

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) = "Cinquenta "

aDezena(6) = "Sessenta ": aDezena(7) = "Setenta ": aDezena(8) = "Ointenta "

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 "

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)

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

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)) >= 1, 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

VExtenso = CFinal

If NValor > 2 And NValor < 2000 And Left(VExtenso, 2) = "UM" Then

VExtenso = Mid(VExtenso, 4, 250)

Else

VExtenso = CFinal

End If

Exit Function

99:

VExtenso = "# ERRO DE VALOR"

Exit Function

End Function

Sub Main()

MsgBox VExtenso("1500")

End Sub