Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
From novice to tech pro — start learning today.
"Can't buy an add in" None available for this, I suppose...
Try this out. One sub to do it, another to undo it
Option Explicit
Sub FindDupes()
Dim msg
Dim i As Long
Dim roe As Long
Dim col As Long
Dim roe2 As Long
Dim col2 As Long
Dim c As Range
Dim cc As Range
Dim cel As Range
Dim rng As Range
Dim firstaddress As String
On Error GoTo endo
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Clear old fill
ActiveSheet.UsedRange.Inte
'Where to scratch
roe = ActiveSheet.UsedRange.Rows
col = ActiveSheet.UsedRange.Colu
col2 = col + 1
'Numbers for re-sort
For i = 1 To 4
Cells(i + 1, col) = i
Next i
Range(Cells(2, col).Address, Cells(5, col).Address).AutoFill _
Destination:=Range(Cells(2
'Dupe col
Set rng = Range("Q2:Q" & roe)
'init
i = 1
'Check all
For Each cel In rng
With rng
Set c = .Find(cel, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Set cc = c
firstaddress = c.Address
Do
'Yellow fill
If c.Address <> firstaddress And Cells(c.Row, col2) = "" Then
Range(Cells(cc.Row, 1).Address, Cells(cc.Row, "AU").Address).Interior.Co
Range(Cells(c.Row, 1).Address, Cells(c.Row, "AU").Address).Interior.Co
'For dupe sort
Cells(c.Row, col2) = i
Cells(cc.Row, col2) = i
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
i = i + 1
Next cel
'Sort on Dupe sort
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range(Cells(2, col2).Address, Cells(roe, col2).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range(Cells(2, 1).Address, Cells(roe, col2).Address)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Original rows
roe = Cells(Rows.Count, col).End(xlUp).Row
'Dupe rows
roe2 = Cells(Rows.Count, col2).End(xlUp).Row + 1
'No dupes
If roe2 = 2 Then
msg = MsgBox("Congratulations, no duplicates found!", vbOKOnly + vbExclamation, "Unique values only")
Else
'Hide else
If roe > roe2 Then
Rows(roe2 & ":" & roe).EntireRow.Hidden = True
End If
'Clean up
Columns(col).Hidden = True
Columns(col2).Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set c = Nothing
Set cc = Nothing
Set cel = Nothing
Set rng = Nothing
'Completed normally
Exit Sub
'Errored out
endo:
msg = MsgBox("Error " & Err.Description, vbOKOnly + vbCritical, Err.Number)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set c = Nothing
Set cc = Nothing
Set cel = Nothing
Set rng = Nothing
End Sub
Sub Undupe()
Dim col As Long
Dim roe As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Where to scratch
roe = ActiveSheet.UsedRange.Rows
col = ActiveSheet.UsedRange.Colu
Columns(col).Hidden = False
Rows.Hidden = False
'Sort on Dupe sort
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range(Cells(2, col).Address, Cells(roe, col).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range(Cells(1, 1).Address, Cells(roe, col).Address)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns(col).Clear
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
http:\\www.members.shae.ca\ExcelVBA