Home Excel - Downloads / Areas Restritas Excel VBA - Faturas Pedidos Recibos

Excel VBA - Faturas Pedidos Recibos

  • - Acesso Livre
  • Documentos

    Ordenar por : Nome | Data | Acessos [ Ascendente ]

    Excel vba fpr recibo com extenso e copia Excel vba fpr recibo com extenso e copia

    popular!
    Adicionado em: 23/12/2010
    Modificado em: 23/12/2010
    Tamanho: Vazio
    Downloads: 4721

    Saberexcel - o site das macros
    Exemplo de Recibo que retorna o valor por extenso, como vários alunos havia pedido como aplicar a função de forma que preenchesse o extenso como se fosse um cheque. Observe que o exemplo você poderá desenvolver um " Preenche_Cheques". Espero que isso possa ajudá-los.
    Fique com Deus. E_Marcondes

    Option Explicit

    'Essa função retorna o extenso de numero, se precisar baixe no final da página o exemplo de planilha.

    Function Extenso(nValor As String) As String

    If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function

    'Declara as variáveis da função
    Dim intContador As Integer
    Dim intTamanho As Integer
    Dim strValor As String
    Dim strParte As String
    Dim strFinal As String
    Dim strGrupo(4) As String
    Dim strTexto(4) As String

    'Define matrizes com extensos parciais
    Dim strUnid(19) As String
    strUnid(1) = "um ": strUnid(2) = "dois ": strUnid(3) = "três ": strUnid(4) = "quatro ": strUnid(5) = "cinco ": strUnid(6) = "seis ": strUnid(7) = "sete ": strUnid(8) = "oito ": strUnid(9) = "nove ": strUnid(10) = "dez ": strUnid(11) = "onze ": strUnid(12) = "doze ": strUnid(13) = "treze ": strUnid(14) = "quatorze ": strUnid(15) = "quinze ": strUnid(16) = "dezesseis ": strUnid(17) = "dezessete ": strUnid(18) = "dezoito ": strUnid(19) = "dezenove "
    Dim strDezena(9) As String
    strDezena(1) = "dez ": strDezena(2) = "vinte ": strDezena(3) = "trinta ": strDezena(4) = "quarenta ": strDezena(5) = "cinqüenta ": strDezena(6) = "sessenta ": strDezena(7) = "setenta ": strDezena(8) = "oitenta ": strDezena(9) = "noventa "
    Dim strCentena(9) As String
    strCentena(1) = "cento ": strCentena(2) = "duzentos ": strCentena(3) = "trezentos ": strCentena(4) = "quatrocentos ": strCentena(5) = "quinhentos ": strCentena(6) = "seiscentos ": strCentena(7) = "setecentos ": strCentena(8) = "oitocentos ": strCentena(9) = "novecentos "

    'Divide o valor em vários grupos
    strValor = Format$(nValor, "0000000000.00")
    strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
    strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
    strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
    strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo

    'Processa cada grupo
    For intContador = 1 To 4
    strParte = strGrupo(intContador)

    intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
    If intTamanho = 3 Then
    If Right$(strParte, 2) <> "00" Then
    strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
    intTamanho = 2
    Else
    strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
    End If
    End If

    If intTamanho = 2 Then
    If Val(Right(strParte, 2)) < 20 Then
    strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
    Else
    strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
    If Right$(strParte, 1) <> "0" Then
    strTexto(intContador) = strTexto(intContador) + "e "
    intTamanho = 1
    End If
    End If
    End If

    If intTamanho = 1 Then
    strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
    End If
    Next intContador

    'Gera o formato final do texto
    If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
    strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
    Else
    strFinal = ""
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
    End If
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
    End If
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(3)) = 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
    Else
    If Val(strGrupo(4)) = 0 Then
    strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
    Else
    strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil, ", "")
    End If
    End If
    If Val(strGrupo(4)) = 0 Then
    strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
    Else
    strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
    End If
    strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
    End If
    If Left(strFinal, 1) = "u" Then
    Extenso = "H" & Mid$(strFinal, 1)
    Else
    Extenso = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
    End If
    Dim aux As String * 150
    aux = Trim(Extenso) ' e alterar esta linha para trim(Extenso)
    While Len(Trim(aux)) <> 150
    aux = Trim(aux) & "-x"
    Wend
    Extenso = aux

    End Function



    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA com Saberexcel

    Aprenda fazer formularios no excel para digitacao Aprenda fazer formularios no excel para digitacao

    popular!
    Adicionado em: 27/07/2011
    Modificado em: 10/08/2011
    Tamanho: Vazio
    Downloads: 731

    Saberexcel - o site de quem precisa aprender Macros Microsft Excel VBA.

    Esses macros do aplicativo Micrososft Excel VBA, inserem uma borda na área ou célula selecionada, a intençao dos macros é ajudá-lo e facilitar a confecção de uma fatura, recibo, contrato e outros, pois há quem pena para fazer esses contratos, há uma maneira aparentemente mais simples, voce deverá primeiramente, autoajustar todas as linhas e colunas para começar o seu trabalho de distribuição de células com bordas para digitação mescladas ou nao. Espero que o exemplo possa lhe ser útil. Fique com Deus, Expedito Marcondes.


    Sub Borda_I()
    '
    ' Borda_I Macro
    ' Macro gravada por: Alunos (SaberExcel_VBA_Treinamentos®) Aprenda Microsoft Excel VBA (Saberexcel)
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    End Sub


    Sub Borda_II()
    '
    ' Borda_II Macro
    ' Macro gravada por: Alunos (SaberExcel_VBA_Treinamentos®) Aprenda Microsoft Excel VBA (Saberexcel
    )
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    End Sub

    Sub Borda_III()
    '
    ' Borda_III Macro
    ' Macro gravada por: Alunos (SaberExcel_VBA_Treinamentos®) Aprenda Microsoft Excel VBA (Saberexcel)
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 50
    End With
    Range("Y6").Select
    Range("AM23").Select
    End Sub






    Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel







    Publicidade
    Compre com segurança, garantia e ótimos preços
    Eletrônicos - Submarino.com.br

    PROMOÇÃO DIDÁTICOS SABEREXCEL



    Adquira já o Acesso Imediato
    à Area de Membros

    Compra Grantida --- Entrega Imediata

    Aprenda Excel VBA com Simplicidade de 
    códigos e Eficácia, Escrevendo Menos e
    Fazendo Mais.

    '-------------------------------------'
    Entrega Imediata:
    +  500 Video Aulas MS Excel VBA
    +  35.000 Planilhas Excel e VBA
    +  Coleção 25.000 Macros MS Excel VBA
    +  141 Planilhas Instruções Loops
    +  341 Planilhas WorksheetFunctions(VBA)
    +    04 Módulos Como Fazer Excel VBA
    +  Curso Completo MS Excel VBA
    +  Planilhas Inteligentes


    Pesquisa Google SaberExcel

    Publicidade Google

    <script type="text/javascript"><!--

    google_ad_client = "ca-pub-2317234650173689";

    /* retangulo 336 x 280 */

    google_ad_slot = "0315083363";

    google_ad_width = 336;

    google_ad_height = 280;

    //-->

    </script>

    <script type="text/javascript"

    src="http://pagead2.googlesyndication.com/pagead/show_ads.js">

    </script>

    Publicidade

    RSFirewallProtected


    Google Associados

    Depoimentos

    Adicione Saberexcel Favoritos

     
     

    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA

    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel,


       Sobre as WorksheetFunctions Funções de Planilhas que retornam valores do VBA