Visual Basic em Português

Página pessoal de Jorge Paulino sobre o Visual Basic (VB.NET, ASP.NET, VB6, VBA) e algumas noticias de tecnologia

Excel: Removendo Registos Duplicados

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!

2 comentários:

Anónimo disse...

As linhas:

Dim dic As New Dictionary

e

dic.Add(tmpString, rng.Row),

apresentam erro.

Levi Shiroma disse...

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

Mensagens Recentes



Microsoft Office Especialist

Membro da Comunidade
Experts-Exchange


Administ. da Comunidade
Portugal-a-Programar



Twitter

Artigos no CodeProject

Artigos no CodeProject

Subscrever Novidades

Endereço de Email:

Delivered by FeedBurner

Seguidores

Histórico