Boa noite.
Para procurar duplicados, adapta esta rotina:
Private Sub CommandButton2_Click()
Sheets("Folha1").Select
ListBox1.Clear
Dim X As Long, QT As Integer
Dim Dup As Variant
Dim EndRow As Long
EndRow = Range("A" & 20000).End(xlUp).Row
Range("J" & 25).Value = ""
For X = EndRow To 1 Step -1
If Range("A" & X) <> "" Then
If Application.WorksheetFunction.CountIf(Range("A1:A" & X), Range("A" & X).Text) > 1 Then
Range("A" & X).Interior.Color = 8454143 'RGB(200, 160, 35)
With Me.ListBox1
.ColumnCount = 2
For Each Dup In Range("A" & X)
.AddItem
ListBox1.ColumnWidths = "70;100"
.List(.ListCount - 1, 0) = Range("A" & X) '.ForeColor = 16711680
.List(.ListCount - 1, 1) = Range("B" & X) '.ForeColor= 255
QT = Range("C" & X).Value
Range("J" & 25).Value = Range("J" & 25).Value + QT
Next Dup
End With
End If
End If
Next X
MsgBox "-- VERIFICAÇÃO CONCLUÍDA. --"
End Sub
Para os eliminar, adapta esta:
Private Sub CommandButton3_Click()
Dim X As Long
Dim EndRow As Long
EndRow = Range("A" & 20000).End(xlUp).Row
For X = EndRow To 1 Step -1
If Range("A" & X).Interior.Color = 8454143 Then
Range("A" & X).EntireRow.Delete
End If
Next X
ListBox1.Clear
MsgBox "-- PROCURE NOVAMENTE DUPLICADOS --"
End Sub
A primeira rotina utiliza o apoio de uma Listbox para apresentar os resultados.
Agora tu, adapta de acordo com as tuas necessidades.
↧