Excel VBA RemoveDuplicates function with case sensitivity - vba

Question

I'm trying to remove some duplicates from selected column, but the function removes all duplicates irrespective of the case. RemoveDuplicates considers lower case, upper case, etc as duplicate. E.g. the function removed CENTRAL, central and Central.
I have simply recorded the following code and only changed it a little bit. I need to keep items with different cases and don't want to remove as duplicates.
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
ActiveWorkbook.Sheets(3).Range("A:A").Clear
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'Range("B12").Select
Selection.End(xlToRight).Select
ActiveWorkbook.Sheets(3).Range("A:A").Clear
End Sub

Answer 1

Try the following code using a Dictionary to remove duplicates with case sensitivity:
Option Explicit
Sub Test()
RemoveDuplicates Sheet1.Range("A1:A12")
End Sub
Sub RemoveDuplicates(rngDataColumn As Range)
'assumes rngDataColumn is a column of data
Dim dic As Object
Dim rngCell As Range
Dim varKey As Variant
Dim lngCounter As Long
'create dictionary
Set dic = CreateObject("Scripting.Dictionary")
'dictionary becomes case sensitive
dic.CompareMode = vbBinaryCompare
'iterate range for unique values
For Each rngCell In rngDataColumn
If Not dic.Exists(rngCell.Value) Then
dic.Add Key:=rngCell.Value, Item:=True
End If
Next rngCell
'clear source range
rngDataColumn.ClearContents
'output unique items - with case sensitivity
lngCounter = 1
For Each varKey In dic.Keys
rngDataColumn(lngCounter, 1).Value = varKey
lngCounter = lngCounter + 1
Next varKey
End Sub
A1:A12 in my test case is as follows:
So, to update your recorded macro, you could try:
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
ActiveWorkbook.Sheets(3).Range("A:A").Clear
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
'use the new function here
RemoveDuplicates Selection
'Selection.RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'Range("B12").Select
Selection.End(xlToRight).Select
ActiveWorkbook.Sheets(3).Range("A:A").Clear
End Sub

Answer 2

I have found here and tested some nice solution, that seems to meet your expectations. You have to paste this function into your project:
Option Compare Binary
Sub deleteExactDuplicates(ByVal rng As Range)
Application.ScreenUpdating = False
With CreateObject("scripting.dictionary")
For Each i In rng.Cells
v = i.Value
If .exists(v) Then
i.ClearContents
Else
.Add v, 1
End If
Next i
End With
On Error Resume Next
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Then, you have to call it in your code. If I understand, you want to remove duplicates from selected range, so the macro would look like this:
Sub test()
deleteExactDuplicates Selection
End Sub
Now, this solution delete not only the values in selected range, but also entire rows, where duplicated values occurred. Are you OK with that, or you need something that removes duplicates only from particular range?