Блог

Я пытаюсь удалить некоторые дубликаты из выбранного столбца, но функция удаляет все дубликаты независимо от регистра. 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
  

Попробуйте следующий код, используя 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
  

Я нашел здесь и протестировал некоторое хорошее решение, которое, похоже, соответствует вашим ожиданиям. Вы должны вставить эту функцию в свой проект:

 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
  

Теперь это решение удаляет не только значения в выбранном диапазоне, но и целые строки, в которых произошли дублированные значения. Вы согласны с этим, или вам нужно что-то, что удаляет дубликаты только из определенного диапазона?