Olá pessoas Excelentes!

E aí? Tudo bem! Estão curtindo nossa promoção de Natal? O Sorteio será dia 24 de dezembro. Ainda dá tempo. Participem!

A dica de hoje é uma adaptação e melhoria na macro que converte qualquer número escrito numa célula para seu valor correspondente em extenso. Ou seja, um número como “R$ 9,90“, por exemplo, retornará “nove reais e noventa centavos” como resultado da fórmula. Essa funcionalidade é muito utilizada em holerites, recibos, comprovantes ou qualquer outra aplicação contábil que necessite alguma planilha.

Na publicação original, ensinei como converter um número no formato da nossa moeda brasileira, o Real. Contudo, um leitor informou sua necessidade de converter para outros formatos de moeda automaticamente de acordo com a formatação que se encontrasse o número na célula.

Vou explicar como fazer para as moedas Dólar e Euro, além do Real, é claro.

A pergunta do leitor

Com relação ao valor por extenso, quero utilizar para REAIS, DÓLAR E EURO.
Essa informação constará em uma célula (Tipo de moeda), tens que como a fórmula escrever por extenso a moeda correspondente.

Comentário feito pelo leitor Vanderlei

 

Respondendo a questão

Como escrever número por extenso no formato de qualquer moeda: real, dólar ou euro

Se você já leu o artigo anterior vai ficar feliz em saber que o comando mágico que permitirá realizar essa proeza será obtido pela propriedade NumberFormat do objeto Range. Serão poucas as modificações. Apenas vamos fazer a comparação do formato aplicado na célula e atribuir o nome da moeda corretamente.

Alguns pontos importantes:

O parâmetro passado na fórmula não poderá mais ser textual. Deverá ser um objeto Range, que corresponde a célula que contêm o número que será convertido para texto. Por quê? Precisamos da referência da célula para podermos verificar o formato nela aplicado. Somente assim será possível identificar a moeda utilizada.

No código original, nós definimos a moeda pelas linhas de comando abaixo:

 

sMoedaPlu = " reais"
sMoedaSing = " real"
If bSufMoeda = True Then sMoedaPlu = " de reais"

Agora, vamos condicioná-la de acordo com a verificação feita na informação obtida de NumberFormat. Lembrando que o parâmetro recebido pela função agora é do tipo Range e nomeado como rngNumeroParaConverter, teremos:

    'Define a moeda
    If InStr(1, rngNumeroParaConverter.NumberFormat, "$$") > 0 Then        'Dolar
        sMoedaPlu = " dólares"
        sMoedaSing = " dólar"
        If bSufMoeda = True Then sMoedaPlu = " de dólares"
    ElseIf InStr(1, rngNumeroParaConverter.NumberFormat, "€") > 0 Then     'Euro
        sMoedaPlu = " euros"
        sMoedaSing = " euro"
        If bSufMoeda = True Then sMoedaPlu = " de euros"
    Else                                                                   'Reais
        sMoedaPlu = " reais"
        sMoedaSing = " real"
        If bSufMoeda = True Then sMoedaPlu = " de reais"
    End If

Viu como é fácil! Você poderá adicionar mais condições para cada moeda diferente que você utilize.

A forma de utilizar a fórmula continua o mesmo. Se o número estiver na célula A1, na célula que quiser exibir o valor por extenso digite:

=ConverterParaExtenso(A1)

 

O código completo

Deverá ser colocado em um módulo.

 

Public Function ConverterParaExtenso(rngNumeroParaConverter As Range) 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
Dim bSufMoeda As Boolean
Dim NumeroParaConverter As String
    Application.Volatile
    'Obtém o valor para converter para extenso
    NumeroParaConverter = rngNumeroParaConverter.Value

    '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
                    sExtensoFinal = sExtensoFinal & " e " & 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
    If InStr(1, rngNumeroParaConverter.NumberFormat, "$$") > 0 Then        'Dolar
        sMoedaPlu = " dólares"
        sMoedaSing = " dólar"
        If bSufMoeda = True Then sMoedaPlu = " de dólares"
    ElseIf InStr(1, rngNumeroParaConverter.NumberFormat, "€") > 0 Then     'Euro
        sMoedaPlu = " euros"
        sMoedaSing = " euro"
        If bSufMoeda = True Then sMoedaPlu = " de euros"
    Else                                                                   'Reais
        sMoedaPlu = " reais"
        sMoedaSing = " real"
        If bSufMoeda = True Then sMoedaPlu = " de reais"
    End If

    'Escreve os Centavos
    sCentavos = EscreveCentavos(sDecimais)

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

    'retorna o resultado
    ConverterParaExtenso = sExtensoFinal

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  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

 

Espero que tenham gostado.

Um abraço e até a próxima.

Antes de efetuar o download do arquivo de exemplo, convido você a socializar conosco.

Escolha uma das opções abaixo. Seguir no twitter, assinar nossa Newsletter...

Isso nos ajuda na divulgação do site e te permite ficar sempre atualizado das novidades. Fico muito grato pela sua colaboração.

Digite seu email:

Você receberá um email para ativar o cadastro, ok!