Excel remove only unique cells - vba

Question

I have been struggling with coming up with a solution to deleting all cells that are unique across my excel sheet.
I have an excel sheet that look something like this:
cat dog shrimp donkey
dog human wale
wale bear
dog donkey shrimp human wale
and I would like to now remove all values that are unique amongst all cells (so here that would be removing cat and bear) while keeping all the order of all the rows etc. intact.
I also have a few rows that are completely empty (but that I can't delete).
I have tried the following macro, but it's my first vba macro (and I know it is stupidly inefficient :) ) For some reason it doesn't delete anything whereas I can't see the logic error.
Code:
Sub doit()
Dim rng As Range
Dim rngtoCheck As Range
Dim cell As Range
Dim isCellUnique As Boolean
Dim cellToCheck As Range
Set rng = Range("A1:Z20")
Set rngtoCheck = Range("A1:Z20")
For Each cell In rng
isCellUnique = True
For Each cellToCheck In rngtoCheck
If cell.Value = cellToCheck.Value AND cell.row <> cellToCheck.row Then
isCellUnique = False
End If
Next cellToCheck
If isCellUnique = True Then
cell.ClearContents
End If
Next cell
End Sub
The idea is that I loop through the entire range and for each cell I check if any other cell in the range has the same value, but is not on the same row. If both check out I keep the value, otherwise I clear the cell.
What am I doing wrong?

Answer 1

You can use Application.WorksheetFunction.CountIf to check if the cell is repeated more than once?
Is this what you are trying?
Tried And Tested
Sub doit()
Dim rng As Range, aCell As Range
'~~> Change this to the relevant sheet
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:Z20")
For Each aCell In rng
If Not Len(Trim(aCell.Value)) = 0 Then
'~~> Check if word occurs just once
If Application.WorksheetFunction.CountIf(rng, aCell.Value) = 1 Then
MsgBox aCell.Value & " is unique"
'
'~~> Do what you want here
'
End If
End If
Next aCell
End Sub