none
extenso_valor RRS feed

  • Pergunta

  • Boa tarde

    estou precisando de ajuda no código VBA extenso_valor.

    exemplo: ao escrever 1800.00€ aparece e bem "mil e oitocentos euros", mas se escrever 1801.00€ aparece "mil e oitocentos e um euros", que está mal, devia aparecer "mil, oitocentos e um euros" .

    isto na classe dos milhares, envio o código que utilizo

    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 = " euro"
    '       Se for maior que 1 a unidade está no plural
            ElseIf WorksheetFunction.RoundDown(valor, 0) > 1 Then
                strMoeda = " euros"
        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 centimo"
            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) & " centimos"
        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 tmpCento = 0 And tmpDez = 0 And tmpunidades = 0) Then
                milString = " mil "
                
                ElseIf (tmpMilhar > 1 And tmpCento = 0 And tmpDez = 0 And tmpunidades = 0) Then
                milString = unidades(tmpMilhar) & " mil "
                
                ElseIf (tmpMilhar = 1 And tmpCento >= 1 And tmpDez = 0 And tmpunidades >= 1) Then
                milString = " mil, "
                 
                ElseIf (tmpMilhar = 1 And tmpCento >= 1 And tmpDez = 0 And tmpunidades = 0) Then
                milString = " mil e "
                                       
                ElseIf (tmpMilhar > 1 And tmpCento >= 1 And tmpDez = 0 And tmpunidades = 0) Then
                milString = unidades(tmpMilhar) & " mil e "
                
                ElseIf (tmpMilhar > 1 And tmpCento >= 1 And tmpDez >= 0 And tmpunidades > 0) 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 <= 1000) Then milString = milString
        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, "
                    ElseIf tmpTrilhao = 0 Then
                        triString = "("
        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

    terça-feira, 23 de agosto de 2016 14:52

Todas as Respostas

  • Ao inserir um código no fórum, utilize blocos de código. Para utilizar essa ferramenta, clique no botão cuja legenda é “Inserir bloco de código” na barra do editor de mensagens do fórum. Uma janela aparecerá onde você deverá colar seu código cru na caixa de texto à esquerda. Então, selecione a opção Vb.Net na caixa de combinação que você verá em cima à esquerda e depois clique no botão Inserir.

    ---

    Experimente usar outra função e adaptar. Creio que seja mais fácil que quebrar a cabeça tentando consertar a função existente.

    http://www.vbatreinamentos.com.br/2016/02/funcao-escrever-por-extenso-no-excel.html


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    domingo, 28 de agosto de 2016 23:21
    Moderador