Remove duplicates but with case sensitive - excel

Question

I am trying to remove duplicates but with case sensitivity.
For example, ABC123 is not the same as abc123, hence, do not remove it.
But ABC123 and ABC123 is the same, hence, remove them.
This is my current code:
Dim oDic As Object, vData As Variant, r As Long
Set oDic = CreateObject("Scripting.Dictionary")
With worksheets(4).Range("A7:A" & lastRow)
vData = .Value
.ClearContents
End With
With oDic
.comparemode = 0
For r = 1 To UBound(vData, 1)
If Not IsEmpty(vData(r, 1)) And Not .Exists(vData(r, 1)) Then
.Add vData(r, 1), Nothing
End If
Next r
Range("A7").Resize(.Count) = Application.Transpose(.keys)
End With
Some background:
The entire dataset has about 800k records
The script has no error, but the result is wrong. When I remove duplicate (regardless of case sensitivity, I have 400k left) but running this script, 450k (which sounds legit), but only 60k records have data, 390k shows #N/A. So I have no idea where went wrong.
Thanks in advance!

Answer 1

As stated in the first comment, Application.Transpose has a limitation of 65,536 array rows. Please, try the next function able to transpose without such a limitation:
Function TranspKeys(arrK) As Variant
Dim arr, i As Long
ReDim arr(1 To UBound(arrK) + 1, 1 To 1)
For i = 0 To UBound(arrK)
arr(i + 1, 1) = arrK(i)
Next i
TranspKeys = arr
End Function
After copying the functionin the same module where your existing code exists, only modify it as:
Range("A7").Resize(.Count,1) = TranspKeys(.keys)

Answer 2

Unique Values Case-Sensitive
Transpose has its limitations and is best avoided (what's a few more lines).
Option Explicit
Sub DictWith()
With Worksheets(4)
Dim LastRow As Long: LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastRow < 7 Then Exit Sub
With .Range("A7:A" & LastRow)
Dim Data As Variant
If .Rows.Count = 1 Then
ReDim Data(1 To 1, 1 To 1)
Data(1, 1).Value = .Value
Else
Data = .Value
End If
With CreateObject("Scripting.Dictionary")
.CompareMode = vbBinaryCompare
Dim Key As Variant
Dim r As Long
For r = 1 To UBound(Data, 1)
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next r
Dim rCount As Long: rCount = .Count
If rCount = 0 Then Exit Sub
ReDim Data(1 To rCount, 1 To 1)
r = 0
For Each Key In .Keys
r = r + 1
Data(r, 1) = Key
Next Key
End With
.Resize(rCount).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents ' clear below
End With
End With
End Sub