Verified answer

FÓRMULA AINDA NÃO HÁ.

MAS VOCÊ PODE RODAR ESTA MACRO, SIMPLESMENTE COLANDO-A E COPIANDO NO GERADOR DE MACROS. DEPOIS DE FEITO ISSO USE A FORMULA "=NUMEROEXTENSO".

Option Explicit

Function NumeroExtenso(ByVal numero) 'Escreve numero por extenso

Dim Reais, Centavos, Temp

Dim PontoDecimal, Contar

ReDim lugar(9) As String

lugar(2) = " Mil "

lugar(3) = " Milhões "

lugar(4) = " Bilhões"

lugar(5) = " Trilhões"

numero = Trim(Str(numero))

'Posição da casa decimal se 0 numero inteiro

PontoDecimal = InStr(numero, ".")

'Converter centavos

If PontoDecimal > 0 Then

Centavos = GetDez(Left(Mid(numero, PontoDecimal + 1) & "00", 2))

numero = Trim(Left(numero, PontoDecimal - 1))

End If

Contar = 1

Do While numero <> ""

Temp = GetCem(Right(numero, 3))

If Temp <> "" Then Reais = Temp & lugar(Contar) & Reais

If Len(numero) > 3 Then

numero = Left(numero, Len(numero) - 3)

Else

numero = ""

End If

Contar = Contar + 1

Loop

Select Case Reais

Case ""

Reais = ""

Case " Um"

Reais = " Um Real"

Case Else

Reais = Reais & " Reais"

End Select

Select Case Centavos

Case ""

Centavos = ""

Case " Um"

Centavos = "Um centavo"

Case Else

Centavos = Centavos & " Centavos"

End Select

If Reais <> "" And Centavos <> "" Then

NumeroExtenso = Reais & " e " & Centavos

ElseIf Reais <> "" Then

NumeroExtenso = Reais

Else

NumeroExtenso = Centavos

End If

End Function

' Converter um numero entre 100 e 999 em texto

Function GetCem(ByVal numero)

Dim resultado As String

If Val(numero) = 0 Then Exit Function

numero = Right("000" & numero, 3)

If Mid(numero, 1, 1) <> "0" Then

resultado = GetDigit(Mid(numero, 1, 1)) ' ALTERAR ESTÁ FUNÇÃO SE 1=CEM ; 2 = DUZENTOS

Select Case resultado

Case " Um": resultado = " Cento e "

Case " Dois": resultado = " Duzentos "

Case " Três": resultado = " Trezentos "

Case " Quatro": resultado = " Quatrocentos "

Case " Cinco": resultado = " Quinhentos "

Case " Seis": resultado = " Seiscentos "

Case " Sete": resultado = " Setecentos "

Case " Oito": resultado = " Oitocentos "

Case " Nove": resultado = " Novecentos "

End Select

End If

' Converte um numero entre 01 e 10 em texto

If Mid(numero, 2, 1) <> "0" Then

resultado = resultado & GetDez(Mid(numero, 2))

Else

resultado = resultado & GetDigit(Mid(numero, 3))

End If

GetCem = resultado

End Function

' Converte um numero de 10 a 99 em texto

Function GetDez(DezTXT)

Dim result As String

result = "" 'Nulo

If Val(Left(DezTXT, 1)) = 1 Then 'Se valor entre 10-19

Select Case Val(DezTXT)

Case 10: result = "Dez"

Case 11: result = "Onze"

Case 12: result = "Doze"

Case 13: result = "Treze"

Case 14: result = "Quatorze"

Case 15: result = "Quinze"

Case 16: result = "Dezesseis"

Case 17: result = "Dezesete"

Case 18: result = "Dezoito"

Case 19: result = "Dezenove"

Case Else

End Select

Else ' Valores entre 20-99

Select Case Val(Left(DezTXT, 1))

Case 2: result = " Vinte"

Case 3: result = " Trinta"

Case 4: result = " Quarenta"

Case 5: result = " Cinquenta"

Case 6: result = " Sessenta"

Case 7: result = " Setenta"

Case 8: result = " Oitenta"

Case 9: result = " Noventa"

Case Else

End Select

result = result & GetDigit(Right(DezTXT, 1)) ' retorna um unico valor

End If

GetDez = result

End Function

'Converte numeros entre 1 e 9 em texto

Function GetDigit(Digit)

Select Case Val(Digit)

Case 1: GetDigit = " Um"

Case 2: GetDigit = " Dois"

Case 3: GetDigit = " Três"

Case 4: GetDigit = " Quatro"

Case 5: GetDigit = " Cinco"

Case 6: GetDigit = " Seis"

Case 7: GetDigit = " Sete"

Case 8: GetDigit = " Oito"

Case 9: GetDigit = " Nove"

Case Else: GetDigit = ""

End Select

End Function

Macro opcional....

Alt + F11

Inserir >>módulo

Copie e cole:

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

Chame a formula:

=extenso()

Abs

#==( o )

Bah Show de bola

É, Domingão, a vida né tão fácil quanto você pensa, não.

Não existe uma fórmula para isso.

Mas pesquisando bem você achará sites de cursos de excel avançado que ensinam como escrever macros, e uma das favoritas (e usadas para "vender" o curso) é a de extenso.

Deixa de preguiça e mãos à obra.