Home Excel - Downloads / Areas Restritas Excel VBA - AutoNumeracao

Excel VBA - AutoNumeracao

  • - Acesso Livre
  • Documentos

    Ordenar por : Nome | Data | Acessos [ Descendente ]

    Excel planilha usf textbox insere dados autonumeracao Excel planilha usf textbox insere dados autonumeracao

    popular!
    Adicionado em: 27/10/2011
    Modificado em: 27/10/2011
    Tamanho: 87.48 KB
    Downloads: 1206

    O site de quem precisa aprender Macros Microsoft Excel VBA

    Procedimentos usados nos Objetos textboxes em um userform, insere uma autonumeração a cada interação, inserindo dados nas células na folha
    de planilha, observe que a linha de código 'vCodigo = Range("A60000").End(xlUp).Offset(0, 0).Value' verifica o número de linhas usadas existentes na coluna(a) e adiciona + 1 a variável vCodigo, que representará o número atual do próximo registro.
    Espero que gostem do exemplo. Fiquem todos na Paz Crsito Nosso Senhor. Expedito Marcondes.


    Private Sub CommandButton1_Click()
    Dim vCodigo As Integer
    ' Adicionando dados na folha de Planilha
    Saber1.Range("A60000").End(xlUp).Offset(1, 0).Select

    'verificando se digitou dados (verifica inconsistencia)
    If TextBox2.Text = "" Then
    MsgBox ("deverá digitar algo na textbox1"), vbInformation, "Saberexcel- o site das macros"
    Exit Sub
    End If

    ActiveCell.Offset(0, 0).Value = Me.TextBox1.Value
    ActiveCell.Offset(0, 1).Value = Me.TextBox2.Value

    'limpa a textbox após a inserção de dados
    Me.TextBox2 = Empty

    'usando a variável vCodigo para memorizar a autonumeração
    vCodigo = Range("A60000").End(xlUp).Offset(0, 0).Value
    Me.TextBox1 = vCodigo + 1
    Me.TextBox2.SetFocus
    End Sub

    Private Sub UserForm_Activate()
    Dim vCodigo
    'Insere uma autonumeração na textbox1
    Saber1.Select
    vCodigo = Range("A60000").End(xlUp).Offset(0, 0).Value
    Me.TextBox1 = vCodigo + 1
    End Sub

    Private Sub UserForm_Initialize()
    'indicando o setfocus para textbox2
    Me.TextBox2.SetFocus
    End Sub


    Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.

    Excel planilha vba autonumeracao orcamento recibo Excel planilha vba autonumeracao orcamento recibo

    popular!
    Adicionado em: 25/11/2011
    Modificado em: 25/11/2011
    Tamanho: 85.01 KB
    Downloads: 1761

    Saberexcel - o site de quem precisa aprender macros ms excel vba

    Esse Macro do Aplicativo Microsoft Excel VBA e Fórmula com a Função (Texto e data Hoje()), com formatação como podem observar abaixo, faz uma formatação personalizada em determinado número envolvendo a data (ano e mês) mais números sucessivos de zeros.
    Esse tipo de formatação é muito útil para quem precisa ter um tipo de autonumeração em recibos, orçamentos e outro documento desejado.
    Espero que o exemplo possa ser útil. Fique com Deus, Expedito Marcondes.

    Esse é o exemplo simples feito na planilha que voce poderá baixar no final da página se quiser.
    ' - - - - - - - - - - - - - - - - - - - - - -


    Fórmula usada:
    =TEXTO(HOJE();"aaaa-")&TEXTO(HOJE();"mm-")&TEXTO(G6;"000000")

    Usei para a autoincrementação que você poderá usar em um evento Open(), cada vez que abrir mudar o número do documento.
    Sub controlar_numero_texto()
    [G6].Value = [G6].Value + 1
    End Sub

    '- - - - - - - - - - - - - - - - - -
    Também poderá salvar o arquivo com qualquer nome desejado a partir desse número do recibo(Celula) + um nome.
    O macro abaixo salva o seu Recibo(a planilha) com nome também formatado pelos valores das células (C4) e também da célula(e4)
    Ex: RECIBO Nº_2011-11-009840 - Para isso basta voce inserir o diretorio corretamente no macro ( ChDir "C:\VBA")

    Sub Salvar_como()
    Dim FNome1 As String
    Dim FNome2 As String

    ChDir "c:\vba\"

    FNome1 = Range("c4").Value
    FNome2 = Range("E4").Value

    ActiveWorkbook.SaveAs Filename:="c:\vba\" + FNome1 + "_" + FNome2 + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close Savechanges:

    End Sub



    Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.



    vba autonumeracao determinado local e extenso numerico vba autonumeracao determinado local e extenso numerico

    popular!
    Adicionado em: 17/11/2010
    Modificado em: 17/11/2010
    Tamanho: 51.31 KB
    Downloads: 799

    Saberexel - o Site das Macros
    Essas macros e Funções do Aplicativo Microsoft Excel VBA, contém insere uma Autonumeração limitada em determinado local da folha de planilha, neste caso vamos inserir 10 (Dez ) interações a iniciando pelo número 7(sete), na coluna(C) na Linha(10), e também vai inserir uma Função Extenso que vai inserir na frente dos números o Extenso 7 (sete), 8(oito) etc, acrescentei a Função Extenso e concatenei alguns caracteres e texto, porque sei que poderá ajudar em muitas Aplicações. Baixe o exemplo no link localizado no final da página. Fique com Deus, Expedito Marcondes.


    Sub Insere_numeracao_em_determinado_lugar()
    Saber1.Cells(10, 3).Select '= C10
    For i = 0 To 10
    Sheets("Plan1").Cells(10 + i, 3) = 7 + i
    ActiveCell.Offset(i, 1).Value = "=""Numero : [ ""&fExtenso(RC[-1])&"" ]""" 'função desloc inserindo a Função Extenso

    Next i
    Sheets("Plan1").Cells(9, 5) = "Contando com Saberexel(VBA)..."
    Saber1.Cells(8, 3).Value = "Usei a Função Extenso para ajudá-los no aprendizado"
    Saber1.Cells(22, 3).Value = "Observe que usei a CONCATENAÇÃO " & " a Função Extenso e Texto"
    End Sub



    EM UM OUTRO MÓDULO SEPARADO INSIRA A FUNÇÃO EXTENSO:

    Option Explicit
    Function fExtenso(Num As Double, Optional FraçTipo As Integer, Optional UndNomeSing As String, Optional UndNomePlur As String, Optional UndMasc As Boolean = True, Optional UmMil As Boolean = True, Optional VirgEntrMilh As Boolean = False) As String
    Dim ExtensInt As String
    Dim ExtensFrac As String
    Dim UndNome As String
    Dim FracNome As String
    Dim Signif As String
    Dim NumText As String

    If Num > 999999999999.99 Or Num < 0 Then
    fExtenso = "Erro! (Valores válidos: >=0 e < 1 trilhão)"
    Exit Function
    End If

    'Preparando nome da unidade, singular e plural
    If Not Mid(UndNomeSing, 2, 1) = UCase(Mid(UndNomeSing, 2, 1)) Then UndNomeSing = LCase(UndNomeSing)
    If UndNomePlur <> "" Then
    If Not Mid(UndNomePlur, 2, 1) = UCase(Mid(UndNomePlur, 2, 1)) Then UndNomePlur = LCase(UndNomePlur)
    Else
    UndNomePlur = IIf(UndNomeSing = "", "", Pluralizar(UndNomeSing))
    'Se a função Pluralizar falhar palavras estrangeiras ou em exceções
    'portuguesas, deve ser usado o argumento UndNomePlur.
    End If

    'Extenso parte inteira
    ExtensInt = fExtensoInt(Int(CDec(Num)), UndMasc, UmMil, VirgEntrMilh)

    'Extenso parte fracionária
    If FraçTipo = 0 And UndNomeSing = "" Then FraçTipo = 3
    If FraçTipo = 0 And UndNomeSing <> "" Then FraçTipo = 1
    Select Case FraçTipo
    Case 1 'Lê fração em centavo. Ideal para Moeda
    Num = Format(Num, "0.00") * 1 'Round(Num,2)
    ExtensFrac = fExtensoInt((Num - Int(CDec(Num))) * 100, True, UmMil, VirgEntrMilh)
    If ExtensInt = "" And ExtensFrac = "" Then ExtensInt = "zero"

    'Nome da unidade no singular ou plural
    UndNome = IIf(Num < 1, IIf(Num = 0, " " & UndNomePlur, ""), IIf(UndNomeSing = "" Or Right(ExtensInt, 1) = " ", "", " ") & IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) & IIf(Num = Int(CDec(Num)), "", " e "))
    'Nome da fração no singular ou plural
    FracNome = IIf(Num = Int(CDec(Num)), "", IIf(Int(CDec(Num * 100)) - Int(CDec(Num)) * 100 = 1, " centavo", " centavos"))

    fExtenso = ExtensInt & UndNome & ExtensFrac & FracNome

    Case 2 'Lê a vírgula decimal, cada zero e o número restante como inteiro. Ideal para percentual.
    ExtensFrac = Num - Int(CDec(Num))
    If ExtensFrac = 0 Then
    fExtenso = ExtensInt
    Else
    ExtensFrac = Format(ExtensFrac, "0.############")
    ExtensFrac = Mid(ExtensFrac, 3, 15)
    fExtenso = IIf(ExtensInt = "", "zero", ExtensInt) & " vírgula"
    Do While Left(ExtensFrac, 1) = "0"
    fExtenso = fExtenso & " zero"
    ExtensFrac = Mid(ExtensFrac, 2, 15)
    Loop
    fExtenso = fExtenso & " " & fExtensoInt(ExtensFrac * 1, UndMasc, UmMil, VirgEntrMilh)
    End If

    If fExtenso = "" Then fExtenso = "zero"

    fExtenso = fExtenso & IIf(UndNomeSing <> "", " ", "") & IIf(Num = 1, UndNomeSing, UndNomePlur)

    Case 3 'Lê a fração de décimo a bilionésimo. Ideal para número puro.
    ExtensFrac = Num - Int(CDec(Num))
    If ExtensFrac = 0 Then
    ExtensFrac = ""
    Else
    ExtensFrac = Format(ExtensFrac, "0.############")
    Signif = Len(ExtensFrac) - 2
    If Signif > 3 And Signif <> 6 And Signif <> 9 And Signif <> 12 Then Signif = Int(CDec(Signif / 3)) * 3 + 3
    If Signif > 0 Then
    ExtensFrac = Format(ExtensFrac, "0.000000000000")
    ExtensFrac = fExtensoInt(Mid(ExtensFrac, 3, Signif) * 1, True, UmMil, VirgEntrMilh)
    FracNome = Choose(Signif, "décimo", "centésimo", "milésimo", , , "milionésimo", , , "bilionésimo", , , "trilionésimo")
    FracNome = " " & FracNome & IIf(ExtensFrac = "um", "", "s")
    Else
    ExtensFrac = ""
    End If
    End If
    If ExtensInt = "" And ExtensFrac = "" Then ExtensInt = "zero"

    If UndNomeSing = "" Then
    fExtenso = ExtensInt & IIf(ExtensInt <> "" And ExtensFrac <> "", ", e ", "") & ExtensFrac & FracNome
    Else
    'Nome da unidade no singular ou plural
    UndNome = IIf(Num < 1, IIf(Num = 0, " " & UndNomePlur, ""), IIf(UndNomeSing = "" Or Right(ExtensInt, 1) = " ", "", " ") & IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) & IIf(Num = Int(CDec(Num)), "", " e "))
    'Nome da fração no singular ou plural
    FracNome = IIf(Num = Int(CDec(Num)), "", FracNome & " de " & UndNomeSing)

    fExtenso = ExtensInt & UndNome & ExtensFrac & FracNome
    End If
    End Select
    End Function

    Private Function fExtensoInt(Num As Double, UndMasc As Boolean, UmMil As Boolean, VirgEntrMilh As Boolean) As String
    'Gramática portuguesa:
    'Regra Geral: Não se intercala a conjunção 'e' e nem vírgula entre posições de milhar.
    'Exceção: Se a milhar posterior for menor que 100 ou for centena inteira (100,200,300...)
    'Alguns gramáticos não aceitam essa exceção e outros já aceitam a vírgula.
    'A variável ConjExc ativa/desativa a exceção
    'A variável VirgEntrMilh usa vírgula entre milhares

    Dim NumText As String
    Dim Ce As String
    Dim Ma As String
    Dim Mõ As String
    Dim Bi As String
    Dim f As String
    Dim ConjExc As Boolean
    ConjExc = True
    If VirgEntrMilh Then ConjExc = False

    If Num = 0 Then
    fExtensoInt = ""
    Exit Function
    End If

    NumText = Format(Num, "000,000,000,000")

    '1º Posição de milhar, Centenas
    Ce = Mid(NumText, 13, 3)
    '2º Posição de milhar, Milhares
    Ma = Mid(NumText, 9, 3)
    '3º Posição de milhar, Milhões
    Mõ = Mid(NumText, 5, 3)
    '4º Posição de milhar, Bilhões
    Bi = Mid(NumText, 1, 3)

    f = fMilharText(Bi, UndMasc) & IIf(Bi > 0, IIf(Bi > 1, " bilhões", " bilhão"), "")

    f = f & IIf(VirgEntrMilh And Bi > 0 And Mõ > 0, ", ", IIf(Bi > 0 And Mõ > 0, " ", ""))
    f = f & IIf(ConjExc And Bi > 0 And Mõ > 0 And (Mõ < 100 Or Right(Mõ, 2) = "00"), "e ", "")

    f = f & fMilharText(Mõ, UndMasc) & IIf(Mõ > 0, IIf(Mõ > 1, " milhões", " milhão"), "")

    f = f & IIf(VirgEntrMilh And Bi + Mõ > 0 And Ma > 0, ", ", IIf(Bi + Mõ > 0 And Ma > 0, " ", ""))
    f = f & IIf(ConjExc And Bi + Mõ > 0 And Ma > 0 And (Ma < 100 Or Right(Ma, 2) = "00"), "e ", "")

    f = f & fMilharText(Ma, UndMasc) & IIf(Ma > 0, IIf(Ma > 1, " mil", " mil"), "")
    If Not UmMil Then If f = "um mil" Then f = "mil" 'Omitir 'um' em 'um mil'

    f = f & IIf(VirgEntrMilh And Bi + Mõ + Ma > 0 And Ce > 0, ", ", IIf(Bi + Mõ + Ma > 0 And Ce > 0, " ", ""))
    f = f & IIf(ConjExc And Bi + Mõ + Ma > 0 And Ce > 0 And (Ce < 100 Or Right(Ce, 2) = "00"), "e ", "")

    f = f & fMilharText(Ce, UndMasc) & IIf(Ce > 0, ",", "")

    f = IIf(Right(f, 1) = ",", Mid(f, 1, Len(f) - 1), f)
    f = IIf(Right(f, 2) = "ão", f & " de", f)
    f = IIf(Right(f, 3) = "ões", f & " de", f)
    fExtensoInt = f
    End Function

    Private Function fMilharText(NumText As String, UndMasc As Boolean)
    'Gramática portuguesa:
    'Regra Geral: Intercala-se a conjunção 'e' entre centenas, dezenas e unidades

    Dim UndText As String
    Dim DezenaText As String
    Dim CentenaText As String
    Const ConjDez_Un = " e " 'Conjunção entre Dezena e Unidade
    Const ConjCen_Dez = " e " 'Conjunção entre Centena e Unidade

    ' Unidade texto
    If Mid(NumText, 2, 1) <> "1" Then
    UndText = Choose(Mid(NumText, 3, 1) + 1, "", IIf(UndMasc, "um", "uma"), _
    IIf(UndMasc, "dois", "duas"), "três", "quatro", "cinco", "seis", _
    "sete", "oito", "nove")
    Else
    UndText = ""
    End If

    'Dezena texto
    If Mid(NumText, 2, 1) <> "1" Then
    DezenaText = Choose(Mid(NumText, 2, 1) + 1, "", "dez", "vinte", _
    "trinta", "quarenta", "cinqüenta", "sessenta", "setenta", _
    "oitenta", "noventa")
    Else
    DezenaText = Choose(Mid(NumText, 3, 1) + 1, "dez", "onze", _
    "doze", "treze", "quatorze", "quinze", "dezesseis", _
    "dezessete", "dezoito", "dezenove")
    End If

    'Centena texto
    If UndMasc Then
    CentenaText = Choose(Mid(NumText, 1, 1) + 1, "", "cento", "duzentos", _
    "trezentos", "quatrocentos", "quinhentos", "seiscentos", _
    "setecentos", "oitocentos", "novecentos")
    Else
    CentenaText = Choose(Mid(NumText, 1, 1) + 1, "", "cento", "duzentas", _
    "trezentas", "quatrocentas", "quinhentas", "seiscentas", _
    "setecentas", "oitocentas", "novecentas")
    End If
    If Mid(NumText, 1, 1) = "1" And Mid(NumText, 2, 2) = "00" Then CentenaText = "cem"

    'Milhar texto
    fMilharText = CentenaText & IIf(Mid(NumText, 2, 2) * 1 > 0 And CentenaText <> "", ConjCen_Dez, "") _
    & DezenaText & IIf(Mid(NumText, 2, 2) * 1 <= 19 Or Right(NumText, 1) = "0", "", ConjDez_Un) _
    & UndText
    End Function

    Function Pluralizar(Sing As String) As String
    Dim e As String
    'Regra geral:
    Pluralizar = IIf(Sing = "", "", Sing & "s")

    'Exceções: (Quase todas)
    ' Nomes terminados em al, el, ol, ul, il
    e = LCase(Right(Sing, 2))
    If e = "al" Or e = "el" Or e = "ol" Or e = "ul" Or e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 1) & "is"
    'Nomes terminados em il
    If e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 2) & "is"
    ' Nomes terminados em r, s, z
    e = LCase(Right(Sing, 1))
    If e = "r" Or e = "s" Or e = "z" Then Pluralizar = Sing & "es"
    ' Nomes terminados em m
    If e = "m" Then Pluralizar = Left(Sing, Len(Sing) - 1) & "ns"
    ' Nomes terminados em m
    If e = "x" Then Pluralizar = Sing
    End Function



    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA - SaberExcel




    vba autonumeracao incrementa ou decrementa um numero vba autonumeracao incrementa ou decrementa um numero

    popular!
    Adicionado em: 17/11/2010
    Modificado em: 17/11/2010
    Tamanho: 22.04 KB
    Downloads: 896

    Saberexcel - o Site das Macros
    Essas macros do Aplicativo Microsoft Excel VBA, incrementa e decrementa um determinadado número em um célula escolhida, neste exemplo de planilha foi feito para execução da macro manualmente, mas você poderá inserir no Evento Auto_Open do Objeto Workook, ao abrir incrementa mais um número.

    Sub Incrementa_autonumeracao()
    Dim ValVelho As Integer
    Dim ValNovo As String

    'retorna o valor corrente (atual)
    ValVelho = Sheets("Autonumeracao").Range("A2").Value
    ValNovo = Format(ValVelho + 1, "0000")

    'insere o novo valor na celula(A2)
    Sheets("Autonumeracao").Range("A2").Value = "'" & ValNovo
    End Sub


    Essa macro decrementa o número na célula (A2)
    Sub Decrementa_autonumeracao_manual()
    Dim ValVelho As Integer
    Dim ValNovo As String

    'retorna o valor corrente (atual)
    ValVelho = Sheets("Autonumeracao").Range("A2").Value
    ValNovo = Format(ValVelho - 1, "0000")

    ' insere o novo valor na celula(A2)
    Sheets("Autonumeracao").Range("A2").Value = "'" & ValNovo
    End Sub


    Aprenda Tudo Sobre o Aplicativo Microsoft Excel VBA - Saber Excel




    vba autonumeracao insere celula b4 vba autonumeracao insere celula b4

    popular!
    Adicionado em: 17/11/2010
    Modificado em: 07/01/2011
    Tamanho: 19.05 KB
    Downloads: 841

    Esta macro do Aplicativo Microsoft Excel VBA, insere uma autonumeração e incrementa o número a cada execução da macro, neste caso escolhemos a célula(B4)

    Sub Autonumeracao_incrementa()
    Dim vCelula As Range
    For Each vCelula In Range("B4").Cells
    vCelula.Value = vCelula.Value + 1
    Next
    End Sub


    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA - com SaberExcel




    Página 1 de 2

    Pesquisa Google SaberExcel

    Publicidade Google

    Publicidade

    Rastreamento Correios

    Digite o número do SEDEX conforme o exemplo:
    Correios do Brasil

    Assinatura SaberExcel

    Google Associados

    Depoimentos

    Visitantes SaberExcel

    Excel VBA Estudos®
    mod_vvisit_countermod_vvisit_countermod_vvisit_countermod_vvisit_countermod_vvisit_countermod_vvisit_countermod_vvisit_countermod_vvisit_counter
    mod_vvisit_counterHoje1991
    mod_vvisit_counterOntem3305
    mod_vvisit_counterEsta Semana5296
    mod_vvisit_counterSemana passada29248
    mod_vvisit_counterEsse mês112810
    mod_vvisit_counterMês passado152026
    mod_vvisit_counterTodos11098071
    Aprenda MS Excel VBA

    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