VBA - Escrevendo valores por extenso no Excel (dica)

VBA - Escrevendo valores por extenso no Excel (dica)

Nesta dica (já manjada por sinal) vou mostrar como podemos automatizar o Microsoft Excel usando a linguagem VBA atribuindo uma macro a uma fórmula para escrever valores por extenso.

Os recursos usados no projeto deste artigo foram:

Microsoft Excel versão 2007;
Conhecimentos básicos sobre planilhas , células, e Visual Basic;

Antes de iniciar temos que realizar duas configurações no Microsoft Excel 2007:

Ativar a guia do desenvolvedor;
Habilitar a execução de macros;

Obs: A necessidade de habilitar a execução de macros é que por padrão, o Excel coloca um nível de segurança mais elevado pois códigos maliciosos podem ser executados em scripts através de macros no Excel.

Para saber como ativa a guia do desenvolvedor e logo em seguida habilitar a execução de macros leia este artigo: VBA - Preparando o ambiente para desenvolvimento com o Excel

Criando a planilha Excel e escrevendo por extenso

Abra então o Excel 2007 , será aberta uma planilha em branco. Clique então no botão no canto superior a esquerda para abrir o menu principal de opções;

Selecione a opção Salvar como e clique no item : Pasta de Trabalho Habilitada para Macro do Excel;

Em seguida informe o nome do arquivo : ValorPorExtenso_Excel

Será aberta o arquivo Excel exibindo as três planilhas padrão: Plan1, Plan2 e Plan3;

Definindo a Macro para escrever por extenso

O que é uma macro?

Uma macro é uma coleção de comandos que você pode aplicar com um único clique. As macros podem automatizar quase tudo que seja possível executar no programa que você está usando e até mesmo permitem fazer coisas que talvez você não soubesse que fossem possíveis.

As macros são programação, mas para usá-las, você não precisa ser um desenvolvedor e nem mesmo ter conhecimento de programação. A maioria das macros que você pode criar nos programas do Office são escritas em uma linguagem chamada Microsoft Visual Basic for Applications, ou VBA.

Em muitos programas do Office, você pode criar uma macro gravando uma série de ações ou escrevendo a macro. Vamos escrever uma macro que será usada para abrir o formulário frmCadastro.

Para isso vamos incluir um Módulo em nosso projeto a partir do menu Inserir -> Módulo;

Após essa operação digite o código abaixo no módulo inserido:(Este código não é de minha autoria foi repassado por um colaborador)

Function Extenso_Valor(valor As Double) As String
    Dim strMoeda    As String
    Dim cents       As Variant
    Dim decimalSep  As String

'   Se o valor for igual ou maior que 1 quatrilhao
'   passar erro e sair da funcao
    If valor > 999999999999999# Then
        Extenso_Valor = "Valor excede 999.999.999.999.999"
        Exit Function
    End If

'   Se valor for igual a 1, a unidade está no singular
    If WorksheetFunction.RoundDown(valor, 0) = 1 Then
'       a string da moeda no singular
        strMoeda = " real"
'       Se for maior que 1 a unidade está no plural
        ElseIf WorksheetFunction.RoundDown(valor, 0) > 1 Then
            strMoeda = " reais"
    End If
    
'   Remove os centavos
    cents = valor - WorksheetFunction.RoundDown(valor, 0)
'   Remove os centavos do valor
    valor = valor - CDbl(cents)
'       Passo o extenso dos centavos
        cents = centavos(CDbl(cents) * 100)
'    End If
'   Caso a string seja diferente de branco e valor seja maior ou igual a 1
    If cents <> "" And valor >= 1 Then
'       acrescentar uma vírgula antes do extenso
        cents = " e " & cents
    End If
'   Iniciar o processo de conversao dos valores longos
    strMoeda = Trim(Trilhoes(valor)) & strMoeda & cents
    strMoeda = Replace(strMoeda, ", e", " e")
    strMoeda = Replace(strMoeda, ", r", " r")
    If Left(strMoeda, 2) = "e " Then
        strMoeda = Mid(strMoeda, 3, Len(strMoeda))
        'ElseIf Left(strMoeda, 5) = "mil e" Then
           ' strMoeda = Mid(strMoeda, 5, Len(strMoeda))
    End If
    vzz = "00000000000000000000"
    vtam = Len(Trim(Mid(Trim(valor), 2, 100)))
    If Right(vzz + vzz + vzz + vzz, vtam) = Mid(Trim(valor), 2, 100) And InStr(UCase(strMoeda), UCase("es ")) > 0 Then
        vetor = Split(strMoeda, " ")
        vtrocar = vetor(UBound(vetor))
        strMoeda = Replace(strMoeda, vtrocar, "de " + vtrocar)
    End If
    Extenso_Valor = strMoeda

End Function

Private Function centavos(valor As Double) As String
    Dim dezena      As Integer
    Dim unidade     As Integer
'   Passa o valor para base decimal
    valor = Round(CDbl(valor / 100), 2)

'   Se for um centavo, escrever valor e sair da funcao
    If valor = 0.01 Then
        centavos = "um centavo"
        Exit Function
    End If
'   Repassa valor para dezenas
    valor = valor * 100

'   Se nao houver dezenas no valor passado
    If dezenas(valor) = "" Then
'       a string centavos fica em branco
        centavos = ""
    Else
'       caso contrário, passar extenso das dezenas e concatenar
'       com a palavra centavos
        centavos = dezenas(valor) & " centavos"
    End If

End Function

Private Function unidades(unidade As Double) As String
    Dim unid(9)
'   Define as unidades a serem usadas
    unid(1) = "um": unid(6) = "seis"
    unid(2) = "dois": unid(7) = "sete"
    unid(3) = "três": unid(8) = "oito"
    unid(4) = "quatro": unid(9) = "nove"
    unid(5) = "cinco"

'   Retorna a string referente a unidade passada para
'   esta funcao
    unidades = Trim(unid(unidade))
End Function

Private Function dezenas(dezena As Double) As String
    Dim dezes(9)
    Dim dez(9)
    Dim intDezena       As Double
    Dim intUnidade      As Double
    Dim tmpStr          As String

'   Define as dezenas a serem utilizadas
    dezes(1) = "onze": dezes(6) = "dezesseis"
    dezes(2) = "doze": dezes(7) = "dezessete"
    dezes(3) = "treze": dezes(8) = "dezoito"
    dezes(4) = "quatorze": dezes(9) = "dezenove"
    dezes(5) = "quinze"

    dez(1) = "dez": dez(6) = "sessenta"
    dez(2) = "vinte": dez(7) = "setenta"
    dez(3) = "trinta": dez(8) = "oitenta"
    dez(4) = "quarenta": dez(9) = "noventa"
    dez(5) = "cinquenta"

'   Calcula o inteiro da dezena
    intDezena = Int(dezena / 10)
'   Calcula o inteiro da unidade
    intUnidade = dezena Mod 10
'   Se o inteiro da dezena for zero
    If intDezena = 0 Then
'       dezenas sao iguais as unidades
        dezenas = unidades(intUnidade)
        Exit Function
    Else:
'       caso contrário, é igual a dez
        dezenas = dez(intDezena)
    End If

'   Se o inteiro da dezena for igual a 1 e
'   o inteiro da unidade for zero, os valores estao
'   entre 11 e 19
    If (intDezena = 1 And intUnidade > 0) Then
        dezenas = dezes(intUnidade)
    Else
'   Caso contrário, valor está entre 20 e 90 inclusive
        If (intDezena > 1 And intUnidade > 0) Then
'           Concatena a string da dezena com a string da unidade
            dezenas = dezenas & " e " & unidades(intUnidade)
        End If
    End If
    dezenas = dezenas
End Function

Private Function centenas(centena As Double) As String
    Dim tmpCento      As Double
    Dim tmpDez        As Double
    Dim tmpUni        As Double
    Dim tmpUniMod     As Double
    Dim tmpModDez     As Double
    Dim centoString   As String
    Dim cento(9)

'   Define as centenas
    cento(1) = "cento": cento(6) = "seiscentos"
    cento(2) = "duzentos": cento(7) = "setecentos"
    cento(3) = "trezentos": cento(8) = "oitocentos"
    cento(4) = "quatrocentos": cento(9) = "novecentos"
    cento(5) = "quinhentos"

'   Calcula o inteiro da centena
    tmpCento = Int(centena / 100)
'   Calcula a parte da dezena
    tmpDez = centena - (tmpCento * 100)
'   Calcula o inteiro da unidade
    tmpUni = Int(tmpDez / 10)
'   Calcula o resto da unidade
    tmpUniMod = tmpUni Mod 10
'   Calcula o resto da dezena
    tmpModDez = tmpDez Mod 10
'   Se centena for cem, definir string como "cem " e sair
    If centena = 100 Then
        centoString = "cem "
    Else
'   Caso contrário definir a string da centena
        centoString = cento(tmpCento)
    End If
'   Avalia se a unidade é maior ou igual a zero, se o resto da unidade é igual ou
'   maior que zero, se a dezena é maior ou igual a um e se a centena é igual ou
'   maior que 1. Se forem verdadeiros; entao, adicionar " e " a string da centena
    If (tmpUni >= 0 And tmpUniMod >= 0 And tmpDez >= 1 And tmpCento >= 1) Then
        centoString = centoString & " e "
    End If
'   Concatena a string do cento com a string da dezena
    centenas = Trim(centoString & dezenas(tmpDez))
End Function

Private Function milhares(milhar As Double) As String
    Dim tmpMilhar      As Double
    Dim tmpCento       As Double
    Dim milString      As String

'   Calcula o inteiro da milhar
    tmpMilhar = Int(milhar / 1000)
'   Calcula o cento dentro da milhar
    tmpCento = milhar - (tmpMilhar * 1000)
'   Se milhar for zero, entao a string da milhar fica em branco
    If tmpMilhar = 0 Then milString = ""
'   Se for igual a 1, entao
 '   If '(tmpMilhar = 1) Then
'       string da milhar é igual a unidade e "mil"
        'milString = unidades(tmpMilhar) & "um mil "
'       se maior que 1 e menor que dez, string igual a unidades
    If (tmpMilhar >= 1 And tmpMilhar < 10) Then
            milString = unidades(tmpMilhar) & " mil, "
'           Se for entre 10 e 100, entao string igual a dezenas
            ElseIf (tmpMilhar >= 10 And tmpMilhar < 100) Then
                milString = dezenas(tmpMilhar) & " mil, "
'               Se for entre 100 e 1000, entao igual string centenas
                ElseIf (tmpMilhar >= 100 And tmpMilhar < 1000) Then
                    milString = centenas(tmpMilhar) & " mil, "
    End If
    'If tmpCento = 1 Then milString = " e "
    If (tmpCento >= 1 And tmpCento <= 100) Then milString = milString & "e "
    milhares = Trim(milString & centenas(tmpCento))
End Function

Private Function milhoes(milhao As Double) As String
'   Ver comentários para milhares acima
    Dim tmpMilhao      As Double
    Dim tmpMilhares    As Double
    Dim miString       As String

    tmpMilhao = Int(milhao / 1000000)
    tmpMilhares = milhao - (tmpMilhao * 1000000)
    If tmpMilhao = 0 Then miString = ""
    If (tmpMilhao = 1) Then
        miString = unidades(tmpMilhao) & " milhão, "
        ElseIf (tmpMilhao > 1 And tmpMilhao < 10) Then
            miString = unidades(tmpMilhao) & " milhões, "
            ElseIf (tmpMilhao >= 10 And tmpMilhao < 100) Then
                miString = dezenas(tmpMilhao) & " milhões, "
                ElseIf (tmpMilhao >= 100 And tmpMilhao < 1000) Then
                    miString = centenas(tmpMilhao) & " milhões, "
    End If
    If milhao = 1000000# Then miString = "um milhão de "
    milhoes = Trim(miString & milhares(tmpMilhares))
End Function

Private Function bilhoes(bilhao As Double) As String
'   Ver comentários para milhares acima
    Dim tmpBilhao     As Double
    Dim tmpMilhao       As Double
    'Dim tmpMilhoes      As Double
    Dim biString       As String

    tmpBilhao = Int(bilhao / 1000000000)
    tmpMilhao = bilhao - (tmpBilhao * 1000000000)
    If (tmpBilhao = 1) Then
        biString = unidades(tmpBilhao) & " bilhão, "
        ElseIf (tmpBilhao > 1 And tmpBilhao < 10) Then
            biString = unidades(tmpBilhao) & " bilhões, "
            ElseIf (tmpBilhao >= 10 And tmpBilhao < 100) Then
                biString = dezenas(tmpBilhao) & " bilhões, "
                ElseIf (tmpBilhao >= 100 And tmpBilhao < 1000) Then
                    biString = centenas(tmpBilhao) & " bilhões, "
    End If
    If bilhao = 1000000000# Then biString = "um bilhão de "
    bilhoes = Trim(biString & milhoes(tmpMilhao))
End Function

Private Function Trilhoes(Trilhao As Double) As String
'   Ver comentários para milhares acima
    Dim tmpTrilhao     As Double
    Dim tmpBilhao       As Double
    Dim triString       As String

    tmpTrilhao = Int(Trilhao / 1000000000000#)
    tmpBilhao = Trilhao - (tmpTrilhao * 1000000000000#)
    If (tmpTrilhao = 1) Then
        triString = unidades(tmpTrilhao) & " trilhão, "
        ElseIf (tmpTrilhao > 1 And tmpTrilhao < 10) Then
            triString = unidades(tmpTrilhao) & " trilhões, "
            ElseIf (tmpTrilhao >= 10 And tmpTrilhao < 100) Then
                triString = dezenas(tmpTrilhao) & " trilhões, "
                ElseIf (tmpTrilhao >= 100 And tmpTrilhao < 1000) Then
                    triString = centenas(tmpTrilhao) & " trilhões, "
    End If
    If Trilhao = 1000000000000# Then triString = "um trilhão de "
    Trilhoes = Trim(triString & bilhoes(tmpBilhao))
End Function

Function arredBaixo(valor)
    Dim tmpValor
    tmpValor = Round(CDbl(Right(Round(valor, 2) * 100, 2)) / 100, 2)
    arredBaixo = Round(Round(valor, 2) - tmpValor, 0)
End Function

Este código define Macro Valor_Extenso que iremos usar para escrever valores por extenso.

Atribuindo a Macro a uma fórmulario

Retorne à planilha Excel e expanda a célula A1 onde iremos digitar os valores numéricos.

Expanda a célula B1 onde os valores por extenso serão escritos.

Selecione a célula B1 e clique no ícone fx;

A seguir na janela - Inserir função - selecione a opção - Definida pelo usuário - e escolha a macro Extenso_Valor;

Na caixa argumentos da função informe a célula onde os valores numéricos serão digitados. No nosso exemplo a célula A1 e clique em OK;

Pronto!

Basta digitar um valor numérico na célula A1 que o valor por extenso será escrito na célula B1, conforme vemos a seguir:

Aguarde em breve outros artigos sobre VBA.

Pegue a planilha com o código VBA aqui: ValorPorExtenso_Excel.zip

Salmos 5:9 Porque não há fidelidade na boca deles; as suas entranhas são verdadeiras maldades, a sua garganta é um sepulcro aberto; lisonjeiam com a sua língua.
Salmos 5:10 Declara-os culpados, ó Deus; que caiam por seus próprios conselhos; lança-os fora por causa da multidão de suas transgressões, pois se revoltaram contra ti.

Veja os Destaques e novidades do SUPER DVD VB (sempre atualizado) : clique e confira !

Quer migrar para o VB .NET ?

Veja mais sistemas completos para a plataforma .NET no Super DVD .NET , confira...

Quer aprender C# ??

Chegou o Super DVD C# com exclusivo material de suporte e vídeo aulas com curso básico sobre C#

José Carlos Macoratti

O que é uma macro?

VBA - Cadastrando clientes e enviando emails - Macoratti.net

VBA-Integrando aplicativos Office - Macoratti.net

VBA - Agenda de Visitas (Excel) - Macoratti.net

VBA - Visual Basic for Aplications - Macoratti.net