PDA

View Full Version : [SOLVED] Remove duplicates from Rows with the last Row only as reference



zouhair_psi
02-16-2017, 01:40 PM
Hello, I would like to apologize first for my bad english

I need help editing a VBA macro.

The macro deletes all duplicates per cell (except the first one) on all columns,raws and starts with the first row.

I would like to change the macro to take the last row only as reference

this is the macro


Sub DeleteDuplicateEntries()
Dim Cell As Range, Cel As Range, N&
Application.ScreenUpdating = False
N = 0
For Each Cell In Selection
'1st loop - (to speed things up ignore any empty cells)
If Cell <> Empty Then
For Each Cel In Selection
'2nd loop - compare non-empty cel values
'and clear contents if it's a duplicated value
If Cel <> Empty And _
Cel.Value = Cell.Value And _
Cel.Address <> Cell.Address Then
Cel.ClearContents
N = N + 1
End If
Next Cel
End If
Next
Application.ScreenUpdating = True
MsgBox "There were " & N & " duplicated entries deleted"
End Sub

for example
A B C D E F G


10
17
25
29
38
44
45


6
9
28
34
35
41
47


9
12
19
26
32
33
38


9
16
26
29
34
43
44











become

A B C D E F G


10
17
25

38

45


6

28

35
41
47



12
19

32
33
38


9
16
26
29
34
43
44



thnx for your help and time

SamT
02-16-2017, 02:18 PM
Change

For Each Cell In Selection
To

For Each Cell In Selection.Rows(Selection.Rows.Count).Row

zouhair_psi
02-16-2017, 02:32 PM
thx for your reply and time

but i got error run-time error '424' object required

p45cal
02-16-2017, 05:37 PM
try changing one character in your code:
Cell.ClearContents

SamT
02-16-2017, 09:05 PM
My bad. Too many "Rows" above


With Selection
For each Cell In .Rows(.Rows.Count)
If Not IsEmpty(Cell) Then
For each cel In .Cells(1).Resize(.Rows.Count - 1, .Columns.Count)
If Cel = Cell Then Cel.ClearContents
Next
End If
next
End With

Faster

Dim ChkRng As Range,TestRng As Range, Cell As Range, Cel As Range
Dim n as long

With Selection
Set ChkRng = .Rows(.Rows.Count)
Set TestRng = .Cells(1).Resize(.Rows.Count - 1, .Columns.Count)
End With

For each Cell in ChkRng
If Not IsEmpty(Cell) Then
For Each Cel in TestRng
If Cel = Cell Then Cel.ClearContents
Next
End If
next

MsgBox n

If you need more speed, use arrays

p45cal
02-17-2017, 03:35 AM
SamT interpreted your requirement better than I did!

If you need more speed, use arrays

Sub DeleteDuplicateEntries2()
Dim ChkRng, TestRng As Range, TRVals, rv, rw As Long, colm As Long, n As Long

With Selection
ChkRng = .Rows(.Rows.Count)
Set TestRng = .Cells(1).Resize(.Rows.Count - 1, .Columns.Count)
TRVals = TestRng.Value
End With

For Each rv In ChkRng
If Not IsEmpty(rv) Then
For rw = 1 To UBound(TRVals)
For colm = 1 To UBound(TRVals, 2)
If TRVals(rw, colm) = rv Then
TRVals(rw, colm) = Empty
n = n + 1
End If
Next
Next
End If
Next
TestRng = TRVals
MsgBox n
End Sub

zouhair_psi
02-17-2017, 07:46 AM
thx for your time and solution

work great.

zouhair_psi
02-17-2017, 04:16 PM
hi,
is posible to add a color to the deleted cells after

or Each rv In ChkRng
If Not IsEmpty(rv) Then
For rw = 1 To UBound(TRVals)
For colm = 1 To UBound(TRVals, 2)
If TRVals(rw, colm) = rv Then
TRVals(rw, colm) = Empty

i did try with cells(rw, colm).interior.color = rgb (255,0,0)

but doesn't work as i excpected

thx for your help

p45cal
02-17-2017, 04:39 PM
Sub DeleteDuplicateEntries3()
Dim ChkRng, TestRng As Range, TRVals, rv, rw As Long, colm As Long, n As Long, RedRng As Range

With Selection
ChkRng = .Rows(.Rows.Count)
Set TestRng = .Cells(1).Resize(.Rows.Count - 1, .Columns.Count)
TRVals = TestRng.Value
End With

For Each rv In ChkRng
If Not IsEmpty(rv) Then
For rw = 1 To UBound(TRVals)
For colm = 1 To UBound(TRVals, 2)
If TRVals(rw, colm) = rv Then
TRVals(rw, colm) = Empty
If RedRng Is Nothing Then Set RedRng = TestRng.Cells(rw, colm) Else Set RedRng = Union(RedRng, TestRng.Cells(rw, colm))
n = n + 1
End If
Next
Next
End If
Next

If n > 0 Then
TestRng = TRVals
RedRng.Interior.Color = RGB(255, 0, 0)
End If
MsgBox n
End Sub

zouhair_psi
02-18-2017, 06:48 AM
work perefect

thx for your time