Удалить повторяющиеся значения, но оставляет строки - PullRequest
Новая
       12

Удалить повторяющиеся значения, но оставляет строки

0 голосов
/ 12 июня 2019

Попытка создать макрос для очистки ВСЕХ повторяющихся значений в столбце, но оставляет строки

Этот работает, но оставляет первый дубликат. Я просто хочу, чтобы что-то в этом дубликате столбца было очищено. 

    Dim lastRow As Long, i As Long
    Application.ScreenUpdating = False
        With Sheets("Sheet1")
            lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
            For i = lastRow To 1 Step -1
                If Application.CountIf(.Range("E1:E" & lastRow), .Range("E" & i)) > 1 Then
                .Range("E" & i).ClearContents
                End If
            Next i
        End With
    Application.ScreenUpdating = True

Вот моя оригинальная таблица:

enter image description here

Вот что мне нужно, чтобы это было:

enter image description here

Ответы [ 2 ]

1 голос
/ 12 июня 2019

Я думаю, что самый простой способ обойти это - сохранить все ячейки, которые нужно очистить, перед тем как очистить, так как это влияет на COUNTIF, и сделать все это за один раз в конце. 

Sub x()

Dim lastRow As Long, i As Long, r As Range

Application.ScreenUpdating = False

With Sheets("Sheet1")
    lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
    For i = lastRow To 1 Step -1
        If Application.CountIf(.Range("E1:E" & lastRow), .Range("E" & i)) > 1 Then
            If r Is Nothing Then
                Set r = .Range("E" & i)
            Else
                Set r = Union(r, .Range("E" & i))
            End If
        End If
    Next i
End With

If Not r Is Nothing Then r.ClearContents

Application.ScreenUpdating = True

End Sub
0 голосов
/ 12 июня 2019

Я бы использовал объект словаря, чтобы собрать ячейки, которые нужно очистить: 

Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub deDup()
    Dim wsSrc As Worksheet, rSrc As Range, C As Range
    Dim Dict As Dictionary, colRng As Collection
    Dim rDel As Range
    Dim v As Variant, w As Variant
    Dim sKey As String

'Set worksheet/range for the column to filter on
Set wsSrc = Worksheets("sheet2")
With wsSrc
    Set rSrc = .Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp))
End With

Set Dict = New Dictionary
    Dict.CompareMode = TextCompare

For Each C In rSrc
    sKey = C.Value2
    If Not Dict.Exists(sKey) Then
        Set colRng = New Collection
        colRng.Add C
        Dict.Add Key:=sKey, Item:=colRng
    Else
        Dict(sKey).Add C
    End If
Next C

For Each v In Dict.Keys
    If Dict(v).Count > 1 Then
        For Each w In Dict(v)
            If rDel Is Nothing Then
                Set rDel = w
            Else
                Set rDel = Union(rDel, w)
            End If
        Next w
    End If
Next v

rDel.Clear

End Sub

Если это происходит слишком медленно, потому что ваши данные очень большие, вы можете

  • выключите ScreenUpdating, Events и установите Calculation на manual
  • или считайте данные в массив VBA и переберите данные таким образом.
...