Remove duplicates from Rows with the last Row only as reference

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

Code:

---

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

Change

Code:

---

For Each Cell In Selection

---

To

Code:

---

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

---

thx for your reply and time

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

try changing one character in your code:
Cell.ClearContents

My bad. Too many "Rows" above

Code:

---

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

Code:

---

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

SamT interpreted your requirement better than I did!

Quote:

---

Originally Posted by SamT

If you need more speed, use arrays

---

Code:

---

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

---

thx for your time and solution

work great.

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

Code:

---

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

---

work perefect

thx for your time