Quando falamos em vários registos, falamos muitas vezes em registos duplicados. A forma usual de os eliminarmos é ordenando a lista e escolher, visualmente ou através de algumas fórmulas, os registos a apagar.
Mas existem maneiras mas simples e mais práticas de o fazer, especialmente se a lista for muito grande, usando o VBA

Neste exemplo será usando um Dictionary do Microsoft Scripting Runtime que será inserido como referência. A principal vantagem de usar este objecto, é que permite pesquisar por um valor na sua colecção através de um simples método Exists(). Isto permite que se faça um ciclo em toda a lista, verifique-se se o registo já existe ou não, e caso exista indicar esse registo para apagar. Finalmente, caso o registo não exista na lista, adiciona-se.
É um processo muito mais simples e prático do que o recurso a arrays.
Para este exemplo, foi indicado que a lista a verificar seria a selecção actual, sem limite de linhas ou colunas. Caso seja necessário, pode-se alterar por uma área(range) fixa, substituindo:
For Each rng In Selection
pela área (range) que pretendemos verificar, como por exemplo:
For Each rng In Range("B5:D14")
Para implementar este pequeno exemplo é necessário abrir o editor de VBA (ALT+F11) e colocar este código associado a um botão. No editor é necessário adicionar a referência ao nosso objecto através do menu Tools –> References seleccionando depois o Microsoft Scripting Runtime.
Para testar é só seleccionar a área a verificar/apagar os registos e correr o código usando o botão.
Sub DeleteDuplicates()
Dim msg As String
msg = "Deseja apagar os registos duplicados na selecção ?"
' Confirma a intenção de continuar
If MsgBox(msg, vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
Dim rng AsRange, rngDelete AsRange
Dim dic As New Dictionary
Dim tmpString As String
Dim x As Byte
Application.ScreenUpdating = False
For Each rng In Selection
tmpString = ""
' Faz um ciclo em todas as colunas seleccionadas
' da linha actual e guarda na variável "tmpString"
Forx = 1 ToSelection.Columns.Count
tmpString = tmpString & rng.Columns(x).Value & "|"
Next x
' Caso não esteja em branco
If tmpString <> vbNullString Then
' Verifica se está no Dictionary
If dic.Exists(tmpString) Then
' Adiciona a célula ao range a apagar
If Not rngDelete Is Nothing Then
rngDelete = Union(rngDelete, rng)
Else
rngDelete = rng
End If
Else
' Adiciona a string e a linha
dic.Add(tmpString, rng.Row)
End If
End If
Next
' Caso exista alguma coisa a apagar
If Not rngDelete Is Nothing Then
rngDelete.EntireRow.Delete
End If
Application.ScreenUpdating = True
dic = Nothing
End If
End Sub
Este exemplo mostra como eliminar registos duplicados, mas através do código apresentado é simples alterar para apenas indicar (colorir por exemplo) os registos que se encontram iguais.
Para que possam testar e modificar o exemplo aqui apresentado, podem descarregar este exemplo: DOWNLOAD
PS: Como sempre, qualquer dúvida, comentário ou correcção ao artigo é sempre bem vinda!
3 comentários:
As linhas:
Dim dic As New Dictionary
e
dic.Add(tmpString, rng.Row),
apresentam erro.
e se quiser eliminar duplicados que estiverem por exemplo entre A1 e X1
1 2 3 4 2 3 5 6 7 8 5 9 10 .......
Eu tenho um codigo muito bom, mas elimina por linha vertical, eu preciso por horizontal, segue ele:
Public Sub ExcluirLinhasDuplicadas()
Dim Col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim Rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Col = ActiveCell.Column
If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If
N = 0
For r = Rng.Rows.Count To 1 Step -1
V = Rng.Cells(r, 1).Value
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
Rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Next r
EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Boa tarde,
Tenho a seguinte situação:
coluna A
12233
12244
12255
16677
13344
12233
Preciso varrer essa coluna a partir de A2 (inicio) até AXX e verificar sempre para trás se o numero já existe, caso exista, apontar o mesmo com outra cor. Muito obrigado por qualquer ajuda.
Enviar um comentário