NÚMEROS POR EXTENSO NO EXCEL 2010

Abra a planilha

Pressione Alt + F11 (VBA)

Menu Inserir > Módulo

Copie e cole a função abaixo:

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

Agora é só usar a Função =EXTENSO()