Question

我正在尝试从所选列中删除一些重复项，但该函数会删除所有重复项，而不管大小写如何。 RemoveDuplicates将小写，大写等视为重复。例如。该功能已移除CENTRAL，central和Central。

我只记录了下面的代码，只是稍微改了一下。我需要保留具有不同情况的项目，并且不希望删除重复项。

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

使用Dictionary尝试使用以下代码删除区分大小写的重复项：

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如下：

因此，要更新录制的宏，您可以尝试：

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

我找到here并测试了一些不错的解决方案，这似乎符合您的期望。您必须将此功能粘贴到项目中：

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

然后，您必须在代码中调用它。如果我理解，您想要从所选范围中删除重复项，因此宏看起来像这样：

Sub test()
   deleteExactDuplicates Selection
End Sub

现在，此解决方案不仅会删除所选范围内的值，还会删除发生重复值的整个行。你还好吗，或者你需要的东西只能从特定范围内删除重复项？

Excel VBA RemoveDuplicates函数，区分大小写

2 个答案: