删除重复但区分大小写

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