Excel VBA RemoveDuplicatesfunction，区分大小写

我试图从选定的列删除一些重复，但该function删除所有重复无论大小写。 RemoveDuplicates认为小写，大写等重复。 例如，function删除CENTRAL ， central和Central 。

我只logging了下面的代码，只是改变了一点点。 我需要保留不同情况下的项目，不想删除重复项目。

 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：我的testing用例中的A12如下：

所以，要更新您录制的macros，您可以尝试：

 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

我在这里find并testing了一些不错的解决scheme，这似乎符合您的期望。 你必须把这个函数粘贴到你的项目中：

 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 

然后，你必须在你的代码中调用它。 如果我明白，你想删除选定范围内的重复，所以macros看起来像这样：

 Sub test() deleteExactDuplicates Selection End Sub 

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