Word Dica MS Office: valor por extenso no word.

eduzsrj · 7 de fevereiro de 2011

Você digita textos com valores frequentemente?

Já pensou usar aquela função de valor por extenso no word?

Sim, agora você pode escrever valores por extenso no word rapidamente.

Então basta salvar a seguinte macro no word:

Sub WValorExtenso()

'    Selection.MoveLeft unit:=wdWord, Count:=1, Extend:=wdExtend

    On Error GoTo Erro

    Selection.MoveStartUntil cset:=" ", Count:=wdBackward
    Selection.TypeText FormatCurrency(Selection.Text, 2) & " (" & ConverterParaExtenso(Selection.Text) & ")"

    GoTo Pula

Erro:

    MsgBox "O valor deve ser informado sem ponto e sem 'R$'." & Chr$(10) & "O cursor deve estar imediatamente após o valor." _
    & Chr$(10) & "O valor não pode estar em início de parágrafo." & Chr$(10) & _
    "Exemplo: 1250,35", vbCritical, "Dados inválidos!"

    Exit Sub

Pula:

End Sub

Public Function ConverterParaExtenso(NumeroParaConverter As String) As String
Dim sExtensoFinal As String, sExtensoAtual As String
Dim i As Integer
Dim iQtdGrupos As Integer
Dim sDecimais As String
Dim sMoedaSing As String, sMoedaPlu As String, sCentavos As String, sConector As String
Dim bSufMoeda As Boolean
Dim vArrCenten As Variant

'Separa os Decimais
If InStr(1, NumeroParaConverter, ",") > 0 Then
sDecimais = Right(NumeroParaConverter, Len(NumeroParaConverter) - InStr(1, NumeroParaConverter, ","))
NumeroParaConverter = Mid(NumeroParaConverter, 1, InStr(1, NumeroParaConverter, ",") - 1)
End If

'Obtém a separação de milhares
iQtdGrupos = Fix(Len(NumeroParaConverter) / 3)
If Len(NumeroParaConverter) Mod 3 > 0 Then
iQtdGrupos = iQtdGrupos + 1
End If

'Chama as funções para escrever o número
If iQtdGrupos > 2 Then bSufMoeda = True

For i = iQtdGrupos To 1 Step -1
sExtensoAtual = DesmembraValor(NumeroParaConverter, i)
If i = 1 Then
If sExtensoAtual = "" Then
sExtensoFinal = sExtensoFinal & sExtensoAtual
Else
If sExtensoFinal = "" Then
sExtensoFinal = sExtensoFinal & sExtensoAtual
Else

vArrCenten = Array("cem", "duzentos", "trezentos", "quatrocentos", _
"quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos")

sConector = ""

For w = 0 To 8
If Len(NumeroParaConverter) >= 4 And Right(NumeroParaConverter, 2) = "00" _
And sExtensoAtual <> vArrCenten(w) Then sConector = "e "
Exit For
Next w

If Len(NumeroParaConverter) >= 4 And Left(Right(NumeroParaConverter, 3), 1) = "0" Then sConector = " e "

If Len(NumeroParaConverter) >= 4 And sExtensoAtual = "cem" Then sConector = " e "

sExtensoFinal = sExtensoFinal & sConector & sExtensoAtual
End If
End If
Else
sExtensoFinal = sExtensoFinal & sExtensoAtual
End If

If iQtdGrupos > 2 Then
Select Case i
Case 1, 2
If sExtensoAtual <> "" Then
bSufMoeda = False
End If
End Select
End If
Next i

'Define a moeda
sMoedaPlu = " reais"
sMoedaSing = " real"

If bSufMoeda = True Then sMoedaPlu = " de reais"

'Escreve os Centavos
sCentavos = EscreveCentavos(sDecimais)

'Adiciona a moeda e os centavos
sExtensoFinal = IIf((sExtensoFinal = ""), "", sExtensoFinal & IIf((sExtensoFinal = "um"), sMoedaSing, sMoedaPlu)) _
& IIf((sExtensoFinal = ""), sCentavos, IIf((sCentavos = ""), "", " e " & sCentavos))

'retorna o resultado

sExtensoFinal = Replace(sExtensoFinal, "  ", " ", 1, , vbTextCompare)

ConverterParaExtenso = Replace(sExtensoFinal, "e e ", "e ", 1, , vbTextCompare)

End Function

Private Function DesmembraValor(sValor As String, iGrupoDiv As Integer) As String
Dim iValor As Integer
Dim sExtenso As String
Dim iDivResto As Integer
Dim iDivInteiro As Integer
Dim iPosInicMid As Integer
Dim iTamMid As Integer
Dim sComplemento As String
Dim vArrDez1 As Variant
Dim vArrDez2 As Variant
Dim vArrCentena As Variant

vArrDez1 = Array("", "um", "dois", "três", "quatro", "cinco", "seis", "sete", "oito", "nove", _
"dez", "onze", "doze", "treze", "quatorze", "quinze", "dezesseis", "dezessete", _
"dezoito", "dezenove")

vArrDez2 = Array("vinte", "trinta", "quarenta", "cinquenta", "sessenta", _
"setenta", "oitenta", "noventa")

vArrCentena = Array("cem", "cento", "duzentos", "trezentos", "quatrocentos", _
"quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos")

'Pega o Valor a ser escrito e desmembra para o grupo numérico correto
iPosInicMid = Len(sValor) - ((3 * iGrupoDiv) - 1)
If iPosInicMid <= 1 Then
iTamMid = 2 + iPosInicMid
Else
iTamMid = 3
End If

If iPosInicMid < 1 Then iPosInicMid = 1

iValor = CInt(Mid(sValor, iPosInicMid, iTamMid))

Select Case iGrupoDiv
Case 2
sComplemento = " mil "
Case 3
If iValor = 1 Then
sComplemento = " milhão "
Else
sComplemento = " milhões "
End If
Case 4
If iValor = 1 Then
sComplemento = " bilhão "
Else
sComplemento = " bilhões "
End If
Case 5
If iValor = 1 Then
sComplemento = " trilhão "
Else
sComplemento = " trilhões "
End If
End Select

Select Case iValor
Case 0 To 19
sExtenso = vArrDez1(iValor)
Case 20 To 99
iDivInteiro = Fix(iValor / 10)
iDivResto = iValor Mod 10

If iDivResto = 0 Then
sExtenso = vArrDez2(iDivInteiro - 2)
Else
sExtenso = vArrDez2(iDivInteiro - 2) & " e " & vArrDez1(iDivResto)
End If
Case 100 To 999
iDivInteiro = Fix(iValor / 100)
iDivResto = iValor Mod 100

If iDivResto = 0 Then
If iDivInteiro = 1 Then
sExtenso = vArrCentena(0)   'Cem
Else
sExtenso = vArrCentena(iDivInteiro) 'inteiro maior que 100
End If
Else
sExtenso = vArrCentena(iDivInteiro) & " e "
Select Case iDivResto
Case 0 To 19
sExtenso = sExtenso & vArrDez1(iDivResto)
Case 20 To 99
iDivInteiro2 = Fix(iDivResto / 10)
iDivResto2 = iDivResto Mod 10

If iDivResto2 = 0 Then
sExtenso = sExtenso & vArrDez2(iDivInteiro2 - 2)
Else
sExtenso = sExtenso & vArrDez2(iDivInteiro2 - 2) & " e " & vArrDez1(iDivResto2)
End If
End Select
End If

End Select

If sExtenso = "um" And sComplemento = " mil " And Len(sValor) < 7 Then
sComplemento = "mil "
sExtenso = ""
End If

smilx = Right(sValor, 6)

If sComplemento = " milhão " Then
If Left(smilx, 2) = "00" And Right(smilx, 5) <> "00000" Then sComplemento = " milhão e " Else sComplemento = " milhão "
End If

If sComplemento = " milhões " Then
If Right(smilx, 6) = "000000" Then
sComplemento = " milhões "
Else
If Left(smilx, 2) = "00" And Right(smilx, 5) <> "00000" Then sComplemento = " milhões e " Else sComplemento = " milhões "
End If
End If

DesmembraValor = sExtenso & IIf(iValor > 0, sComplemento, "")

End Function

Private Function EscreveCentavos(sCent As String) As String
Dim sExtenso As String
Dim iDivResto As Integer
Dim iDivInteiro As Integer
Dim sComplemento As String
Dim vArrDez1 As Variant
Dim vArrDez2 As Variant
Dim iCent As Integer

vArrDez1 = Array("", "um", "dois", "três", "quatro", "cinco", "seis", "sete", "oito", "nove", _
"dez", "onze", "doze", "treze", "quatorze", "quinze", "dezesseis", "dezessete", _
"dezoito", "dezenove")

vArrDez2 = Array("vinte", "trinta", "quarenta", "cinquenta", "sessenta", _
"setenta", "oitenta", "noventa")

'Adequando para duas casas decimais
iCent = Fix(sCent & String(2 - Len(sCent), "0"))

'Escrevendo Singular ou plural
If iCent = 1 Then
sComplemento = " centavo"
Else
sComplemento = " centavos"
End If

'Calculando os valores
Select Case iCent
Case 0 To 19
sExtenso = vArrDez1(iCent)
Case 20 To 99
iDivInteiro = Fix(iCent / 10)
iDivResto = iCent Mod 10

If iDivResto = 0 Then
sExtenso = vArrDez2(iDivInteiro - 2)
Else
sExtenso = vArrDez2(iDivInteiro - 2) & " e " & vArrDez1(iDivResto)
End If
End Select

EscreveCentavos = IIf(iCent > 0, sExtenso & sComplemento, "")

End Function

Código da sub WValorExtenso criado por mim.

Código da função ConverterParaExtenso obtido em http://www.exceldoseujeito.com.br/2008/12/22/escrever-numero-por-extenso/ com adaptações feitas por mim.

Depois é só atribuir um atalho de teclado para ela, por exemplo CTRL+0, da seguinte forma:

1) clique com o botão direito do mouse sobre a faixa de opções e selecione "Personalizar a Faixa de Opções";

2) Embaixo, à esquerda, clique em Atalhos de Teclado: "PERSONALIZAR";

3) Na janela que se abrirá, na lista da esquerda, role até embaixo e selecione MACRO;

4) Na lista da direita, selecione WValorExtenso;

5) Entre no campo "Pressione a nova tecla de atalho" e tecle CTRL+0;

6) Tcle ATRIBUIR e, depois, FECHAR.

Agora bastará teclar CTRL+0 ao lado de uma valor para formatá-lo e escrevê-lo por extenso automaticamente.

Exemplo:

O micro vale 1200,00

Resultado: O micro vale R$ 1.200,00 (mil e duzentos reais)

(observe que a macro formata o número direitinho e que o cursor deve estar imediatamente após o último dígito do valor antes de teclar CTRL+0)

Espero que seja útil para vocês.

Att.

Eduardo

DPRSILVA · 18 de outubro de 2012

Amigo,

Como eu tiro o "R$"?

Trabalho com muitos valores em word, mas não referentes a moeda.

abraço

Littlebudy · 3 de agosto de 2016

Bom dia, fiz questão de me registrar no fórum somente para lhe agradecer pela informação compartilhada conosco, esse código me ajudou muito pois trabalho com recibos e tenho (tinha) que escrever os valores de cada recibo por extenso, Muito obrigado mesmo!!!!

luangabs · 10 de março de 2017

Bom dia! Também fiz questão de me registrar no fórum para agradecer por essa informação valiozíssima! Queria aproveitar parar sugerir, porque eu não tenho muita experiência em VBA, outro problema: passar para extenso as porcentagens, assim como descrito no link

http://www.migalhas.com.br/Gramatigalhas/10,MI24539,91041-Como+se+le+8347

A forma de escrever por extenso nesse caso é diferente, implicando num código provavelmente bem diferente também. Abraços!

luangabs · 19 de março de 2017

Conseguir adaptar o código do eduzsrj, nesse link Só deixo um adendo ao código dele: no final da execução do código, onde acontece o último "replace", é preciso escrever na seguinte forma

ConverterParaExtenso = Replace(sExtensoFinal, " e e ", " e ", 1, , vbTextCompare)

trocando-se o termo "e e " por " e e ", e o termo "e " por " e " (notar os espaços), pois dava problema no caso, por exemplo, do número 23 (ao invés de "vinte e três", o código lia a sequência "e e " e trocava-a por "e ", ficando então "vinte três").

Luana de Olvieira · 20 de setembro de 2017

Olá, passando só pra agradecer pelo código.
Ajudou muito!!

Abraço!

Leandro Magalhães Rocha · 28 de novembro de 2019

Passando pra agradecer por compartilhar, muito obrigado, me ajudou bastante!

Ela funciona redondinha, só que agora, pra facilitar ainda mais, preciso fazer um formulário onde o usuário digitará só nos campos necessários (óbvio, rsrs), daí, ao mandar rodar a macro pelo campo de texto (controle de formulário) retorna o seguinte erro:

Dados Inválidos!
O valor deve ser informado sem ponto e sem 'R$'.
O cursor deve estar imediatamente após o valor.
O valor não pode estar em início de parágrafo.
Exemplo: 1250,35

Nesse caso, como faço pra que, ao digitar no campo e teclar TAB pra ir pro próximo campo ele faça essa conversão automática?

Muito obrigado!

AlexandreCZ · 4 de setembro de 2021

Muito bem!
Eu acho que já deveria vir no Word um código assim.
Mas, como não veio até agora, a comunidade cria a solução.
Parabens!
Me inscrevi aqui para colocar esse comentário e agradecer, funciona perfeitamente.
Abraço

Carolina Adler · 16 de março de 2022

Em 04/09/2021 às 19:20, AlexandreCZ disse:

Muito bem!
Eu acho que já deveria vir no Word um código assim.
Mas, como não veio até agora, a comunidade cria a solução.
Parabens!
Me inscrevi aqui para colocar esse comentário e agradecer, funciona perfeitamente.
Abraço

Como eu faço para ativar? Estou tentando e até agora não consegui!

ss_cwb · 6 de junho de 2023

Fiz uma atualização na macro, melhorando a seleção do número, e eliminando a necessidade de estar no começo no parágrafo, de não ter pontos ou o símbolo de R$. Primeiro, crie a seguinte function:

Function LimpaNumero(numero As String) As String

Dim tempNum As String

tempNum = numero

tempNum = Replace(tempNum, ".", "")

Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "([\d+\.]+)"
    re.IgnoreCase = True
    re.Global = True

    If (re.Test(tempNum) = True) Then
        Set matches = re.Execute(tempNum)   '~~~> Execute search

        If matches.Count > 1 Then
            ' MsgBox "Deu mais que um número: " & matches.Count
            LimpaNumero = matches(0).Value & "," & matches(1).Value
        Else
            ' MsgBox "Deu só um número: " & matches.Count
            LimpaNumero = matches(0).Value
        End If

    End If
    
End Function



Depois, altere a sub para o seguinte:



Sub EscreveExtenso()
Dim selecionado As String

    On Error GoTo Erro
    
    selecionado = LimpaNumero(Selection)
    selecionado = FormatCurrency(selecionado, 2) & " (" & ConverterParaExtenso(selecionado) & ") "
    Selection.Text = selecionado

    GoTo Pula

Erro:

    MsgBox "O valor deve ser informado sem ponto e sem 'R$'." & Chr$(10) & "O cursor deve estar imediatamente após o valor." _
    & Chr$(10) & "O valor não pode estar em início de parágrafo." & Chr$(10) & _
    "Exemplo: 1250,35", vbCritical, "Dados inválidos!"

    Exit Sub

Pula:

End Sub

O restante da função pode ser o mesmo.

Um exemplo como vai ficar no Word:

Texto original:

O valor de 23455 foi depositado.

Selecione o número de qualquer maneira (não precisa ser exato) e use ALT + F8 para executar a sub EscreveExtenso:

O valor de R$ 23.455,00 (vinte e três mil quatrocentos e cinquenta e cinco reais) foi depositado.

wtavares · 25 de agosto de 2023

Parabéns por dividir conhecimento, ajudou muuuuito.

Estou precisando de uma solução para o mesmo problema que o @Leandro Magalhães Rocha citou. Preencher por extenso, um campo de formulário com o valor digitado.

Se mais alguma mente brilhante poder disponibilizar a solução ficaremos agradecido.