Notifications
Clear all

Código em VBA para número repetido ou fora da ordem

9 Posts
2 Usuários
0 Reactions
1,783 Visualizações
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

.
Olá, pessoal!

Pesquisando no motor de busca do Google no Planilhando encontrei a macro/código abaixo no link: viewtopic.php?f=10&t=16975.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target.Column = 1 Then
        ActiveSheet.Sort.SortFields.Clear
        Application.EnableEvents = False
        
        With ActiveSheet.Range("A1", Range("A" & Rows.Count).End(xlUp).Address)
            .Sort Key1:=[A2], Order1:=xlAscending, Header:=xlYes
            .RemoveDuplicates Columns:=1, Header:=xlYes
        End With
        
    End If
    
    Application.EnableEvents = True
    
End Sub

Estou querendo usar o VBA/Macro para ordenar a sequência numérica na coluna A, eliminando números repetidos.

Mas sempre que preciso inserir linha na tabela, a macro VBA apresenta o Erro em tempo de execução '1004':
"Esta operação exige que células mescladas sejam do mesmo tamanho."
ou a eliminação de células
(e não só os valores repetidos) no final da tabela.

Seguem abaixo imagens e link do arquivo:

ARQUIVO: https://www.dropbox.com/s/hmcnndq8bao6g ... .xlsm?dl=0

Grato pela atenção!
Orlando Souza

:geek:

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 14/02/2017 12:18 pm
brunoxro
(@brunoxro)
Posts: 698
Honorable Member
 

Boa noite Orlando,

Deixa ver se entendi, você quer renumerar a coluna A antes de salvar em PDF?

att,

 
Postado : 14/02/2017 9:02 pm
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

oi, @brunoxro! Não. Renumerar a coluna A sempre que eu inserir linha na tabela.

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 14/02/2017 9:07 pm
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 


(...)
Mas sempre que preciso inserir linha na tabela, a macro VBA apresenta o Erro em tempo de execução '1004':
"Esta operação exige que células mescladas sejam do mesmo tamanho." (...)

inclusive, esse mesmo erro aparece quando tento também renumerar a coluna A após eu excluir linhas.
Desativando o código depois de ambas as situações.
:x

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 14/02/2017 9:41 pm
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

.
Encontrei outro código, abaixo, que parece mais estável na execução do que aquele que postei antes aqui.
Só preciso fazer as adaptações necessárias para a coluna A da minha tabela:

Remover os itens repetidos de uma coluna na planilha e colocá-los em ordem alfabética

Sub removerItensRepetidos()


linha = 1


While Sheets(1).Cells(linha, 1) <> ""

linha = linha + 1

Wend

linha = linha - 1

While linha >= 2

If Sheets(1).Cells(linha, 1) = Sheets(1).Cells(linha - 1, 1) Then

Sheets(1).Cells(linha, 1) = "Item repetido"

End If

linha = linha - 1

Wend

While Sheets(1).Cells(linha + 1, 1) <> ""

    If Sheets(1).Cells(linha + 1, 1) = "Item repetido" Then
    
        linhaBranco = 1
        
        While Sheets(1).Cells(linhaBranco, 1) <> ""
        
            linhaBranco = linhaBranco + 1
        
        Wend
        
        For i = linha + 2 To linhaBranco - 1
        
            Sheets(1).Cells(i - 1, 1) = Sheets(1).Cells(i, 1)
        
        Next i
        
        If Sheets(1).Cells(linhaBranco - 1, 1) = "Item repetido" Then
        
        Sheets(1).Cells(linhaBranco - 1, 1) = ""
        
        End If
        
    End If
    
    linha = linha + 1

Wend

    linhaBranco = 1
    
    While Sheets(1).Cells(linhaBranco, 1) <> ""
    
        linhaBranco = linhaBranco + 1
    
    Wend
    
    For i = 1 To linhaBranco - 1
    
        If Sheets(1).Cells(i, 1) > Sheets(1).Cells(i + 1, 1) Then
        
            If Sheets(1).Cells(i + 1, 1) <> "" Then
            
                anterior = Sheets(1).Cells(i, 1)
                posterior = Sheets(1).Cells(i + 1, 1)
                Sheets(1).Cells(i + 1, 1) = anterior
                Sheets(1).Cells(i, 1) = posterior
            
            End If
            
        End If
    
    Next i

End Sub

FONTE: https://sites.google.com/site/vadyboo/rirpoa
Tutorial1: https://www.youtube.com/watch?v=P6Xe1tIFsDA
Tutorial2: https://www.youtube.com/watch?v=UBbD1DhdO8Q

:roll:

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 15/02/2017 8:47 am
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

.
Consegui resolver o erro na planilha, acusado pelo código.

Agora, gostaria de evitar a exclusão das células no final da tabela,
após renumeração da coluna A através do código a seguir:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error Resume Next

    If Target.Cells.Count > 1 Then Exit Sub
    
    If Target.Column = 1 Then
        ActiveSheet.Sort.SortFields.Clear
        Application.EnableEvents = False
        
        With ActiveSheet.Range("A1", Range("A" & Rows.Count).End(xlUp).Address)
            .Sort Key1:=[A2], Order1:=xlAscending, Header:=xlYes
            .RemoveDuplicates Columns:=1, Header:=xlYes
        End With
        
    End If
    
    Application.EnableEvents = True
    
End Sub

Seguem também novo arquivo-modelo e duas imagens:


Grato pela atenção!
Orlando Souza

:geek:

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 15/02/2017 7:55 pm
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

.
O código abaixo seria o melhor dos que já postei até agora,
se ele conservasse a formatação na coluna A e se não fosse
pelos travamentos na planilha:

Sub incrementar()
    
    On Error Resume Next
    
    Dim ultimaLinha As Long, contador As Long
    Dim coluna As String
    
    coluna = "F"
    With Plan1
        ultimaLinha = .Cells(Rows.Count, coluna).End(xlUp).Row
        coluna = "A"
        .Range("A2:A" & ultimaLinha * 100).Clear
        For i = 1 To ultimaLinha - 1
            .Cells(i + 1, coluna).Value = i
        Next
    End With

End Sub

FONTE: viewtopic.php?t=18119&p=91591

:|

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 20/02/2017 7:05 am
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

.
Encontrei o código a seguir que conserva a formatação na coluna A,
mas não (re)numera automaticamente essa coluna. Ou seja, o contrário do código anterior:

Sub numeração_sem_interrupcao()
       i = Plan1.Cells(Cells.Rows.Count, "a").End(xlUp).Row + 1
       For j = 2 To i
            If IsNumeric(Plan1.Cells(j - 1, 1)) Then
                 Plan1.Cells(j, 1) = Plan1.Cells(j - 1, 1) + 1
            Else
                 Plan1.Cells(j, 1) = 1
            End If
       Next
   End Sub

FONTE: http://excelmax.blogspot.com.br/2012/12 ... m-vba.html

Tentei mesclar algumas linhas de comando dos dois últimos códigos, porém não deu certo.
Conforme planilha modelo abaixo:

:(

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 20/02/2017 12:37 pm
OrlandoS
(@orlandos)
Posts: 104
Estimable Member
Topic starter
 

.
Ufa!!! :lol:
Até que enfim encontrei o código:

Sub Auto_NumerAleVBA()
With Range("A2")
    .Formula = "=row(A1)"
    With .Resize(Range("B" & Rows.Count).End(xlUp).Row - 1)
        .FillDown
        .Copy
        .PasteSpecial xlPasteValues
        End With
    End With
    Application.CutCopyMode = False
End Sub

FONTE: viewtopic.php?f=10&t=6219

Só não consegui fazê-lo funcionar sozinho, logo após incluir/excluir linhas
ligadas à coluna A da tabela. Talvez isso não seja possível!

Vou tentar outra alternativa nas opções indicadas pelo link http://www.funcaoexcel.com.br/macro-que ... ticamente/

[ ]'s

8-)

PS: Se a resposta foi útil, clique na "mãozinha positiva" ou em "curtir" na fonte de link informada, agradecendo ao colaborador do código/fórmula. Eu já fiz a minha parte! :]

 
Postado : 22/02/2017 9:21 am