Identifying Duplicates in Excel - excel

Question

I'm trying to identify duplicate cells in a macro. I'm trying to use macros so I can extract the entire row once the duplicate is identified.
I used this code:
Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613")
iWarnColor = xlThemeColorAccentz
For Each rngCell In rng.Cells
vVal = rngCell.Text
If (WorksheetFunction.CountIf(rng, vVal) = 1) Then
rngCell.Interior.Pattern = xlNone
Else
rngCell.Interior.ColorIndex = iWarnColor
End If
Next rngCell
End Sub
but it only identified empty cells. At the moment I'm trying to only identify duplicate text and I'll extract them later.
Can you please help me do that?

Answer 1

You don't need to put rng.Cells - the .Cells is implied - just use rng
(^ This is semantics - do whatever you want)
Instead of checking rngCell.Text - try rngCell.Value.
.Text is incredibly slow.
^ Really, based on this, should probably use .Value2 instead of .Value for maximum speeeeeeed!
Of course, if we are that concerned, we would use a variant array, but let's keep it simple.
Also, idk why you use xlThemeColorAccentz and ColorIndex
This may work, but it doesn't work for me - I would just use RGB
You're doing a CountIf on the range which is sort of meh.
As for checking duplicates,
I would recommend using a dictionary for this purpose.
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Your code becomes:
Sub MarkDuplicates()
Dim iWarnColor As Long
Dim rng As Range
Dim rngCell As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613")
rng.Interior.ColorIndex = xlNone 'Optionally clear all coloring
iWarnColor = RGB(230, 180, 180) 'Red
For Each rngCell In rng
If rngCell.Value <> "" Then 'Ignore blank cells
If Not dict.Exists(rngCell.Value) Then
dict.Add rngCell.Value, rngCell.Row 'Store the row if we want
Else
rngCell.Interior.Color = iWarnColor
'Optionally color the original cell:
'Sheets("AllAccounts (12-05-2017)").Cells(dict(rngCell.Value), "D").Interior.Color = RGB(180, 230, 180)
End If
End If
Next rngCell
End Sub
Results with optional coloring:
Edit (Not Using Dictionary):
So, you're using a mac - oh wellz.
I didn't mention it before, but you can use conditional formatting to solve this.
Anyway, let's just use a collection.
A collection works a lot like a dictionary, but we typically have to loop through it to determine if a particular Key/Value pair exists.
We can cheat this by trying to get a value for a key that doesn't exist and catch the error - I added a function to simplify this process.
Sub MarkDuplicates()
Dim iWarnColor As Long
Dim rng As Range
Dim rngCell As Variant
Dim Col As New Collection
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613")
rng.Interior.ColorIndex = xlNone
iWarnColor = RGB(230, 180, 180)
For Each rngCell In rng
If rngCell.Value <> "" Then 'Ignore blank cells
If Not IsInCollection(Col, rngCell.Value2) Then
Col.Add rngCell.Row, Key:=rngCell.Value2
Else
rngCell.Interior.Color = iWarnColor
'Optionally color the original cell
Sheets("AllAccounts (12-05-2017)").Cells(Col(rngCell.Value2), "D").Interior.Color = RGB(180, 230, 180)
End If
End If
Next rngCell
End Sub
Function IsInCollection(Col As Collection, Val As Variant) As Boolean
On Error Resume Next
Debug.Print (Col(Val))
IsInCollection = (Err.Number = 0)
On Error GoTo 0
End Function
New Results (The Same):

Answer 2

I suppose there are several ways to do this. Here is one.
Option Explicit
Sub FilterAndCopy()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Application.ScreenUpdating = False
With wstSource
Set rngMyData = .Range("A1:XF" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(1, 1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub