Удалить повторяющиеся строки, сохранить последний и удалить первым

Question

Я пытаюсь найти код, который ищет в столбце D любой дублирующий текст, а затем удаляет всю строку, в которой находится первый дубликат.пробелы между строками, поэтому использование кода .End(xl)Up не работает, если только вы не можете нацелиться на весь столбец независимо от пробелов между строками.

До сих пор я пробовал два метода, но ни один из них не оправдал моих ожиданий.

Это был мой первый метод, который не работает, так как на листе есть структура:

Sub test()

ActiveSheet.Range("D:D").RemoveDuplicates Columns:=1, header:=xlNo

End Sub

Это был мой второй метод, который я получил с другого сайта, который работает в течение нескольких минут, но, похоже, не выполняет то, чего я пытаюсь достичь.

Sub Row_Dupe_Killer_Keep_Last()
Dim lrow As Long

For lrow = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
    If Cells(lrow, "D") = Cells(lrow, "D").Offset(-1, 0) Then
       Cells(lrow, "D").Offset(-1, 0).EntireRow.Delete
    End If

Next lrow
End Sub

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

Answer 1

Это должно помочь вам.

    Option Explicit

    Const c_intMaxBlanks As Integer = 5
    Const c_AbsoluteMaxRowsInSheet As Integer = 5000

    Public Sub RunIt()
        Row_Dupe_Killer_Keep_Last ActiveSheet.Range("D:D")
    End Sub

    Public Sub Row_Dupe_Killer_Keep_Last(rngCells As Range)

        Dim iRow As Integer, iCol As Integer
        Dim intBlankCnt As Integer
        Dim intMaxBlanks As Integer
        Dim blnIsDone As Boolean
        Dim intSaveStartRow As Integer
        Dim blnStartCnt As Boolean
        Dim strTemp As String
        Dim strCheck As String
        Dim intI As Integer
        Dim intJ As Integer
        Dim intSaveEndRow As Integer


        'First, Count the consecutive blanks
        blnIsDone = False
        blnStartCnt = False
        intSaveStartRow = 0
        intSaveEndRow = 0
        intBlankCnt = 0
        iRow = 1
        iCol = rngCells.Column
        Do While (Not blnIsDone)
            'Check for blank Row using length of string
            If (Len(Trim(rngCells.Cells(iRow, 1).Value)) < 1) Then  
                If Not blnStartCnt Then
                    intSaveStartRow = iRow
                    blnStartCnt = True
                Else
                    If (intSaveStartRow + intBlankCnt) <> iRow Then
                        'restart
                        intSaveStartRow = iRow
                        intBlankCnt = 0
                    End If
                End If
                intBlankCnt = intBlankCnt + 1
            Else
                'restart
                blnStartCnt = False
                intBlankCnt = 0
            End If

            intSaveEndRow = iRow

            If intBlankCnt >= c_intMaxBlanks Then blnIsDone = True

            'Stop Loop: Maybe Infinite"
            If iRow > c_AbsoluteMaxRowsInSheet Then Exit Do
            iRow = iRow + 1
        Loop

        'Now, loop through each row in the column and check values.
        For intI = intSaveEndRow To 2 Step -1
            strTemp = LCase(Trim(rngCells.Cells(intI, 1).Value))
            For intJ = intSaveEndRow To 2 Step -1
                If intJ <> intI Then
                    strCheck = LCase(Trim(rngCells.Cells(intJ, 1).Value))
                    If strTemp = strCheck Then
                        'Found a dup, delete it
                        rngCells.Cells(intJ, 1).EntireRow.Delete
                    'ElseIf Len(strCheck) < 1 Then
                    '    'Delete the blank line
                    '    rngCells.Cells(intJ, 1).EntireRow.Delete
                    End If
                End If
            Next intJ
        Next intI

    End Sub

Answer 2

Этот метод позволяет избежать использования EntireRow.Delete, который известен своей медлительностью.Содержимое очищается, а набор данных сортируется для удаления пробелов.

РЕДАКТИРОВАТЬ: переключено на «Далее» для включения поиска снизу вверх;также очищена подпрограмма сортировки, сгенерированная устройством записи макросов ... У меня никогда не было этой подпрограммы, когда она мне нужна:).

Примечание: это также не будет работать с контуром ...Вы сделали так, чтобы это сработало, потому что другой ответ нужно будет сделать и для этого.

Мне любопытно, подходит ли вам подход «Очистить / Сортировать» и ускорит ли ваш распорядок дня.

Option Explicit
Sub RemoveFirstDuplicate()
    Dim myDataRange As Range, iCounter As Long, myDuplicate As Range, lastRow As Long
    lastRow = Range("D1000000").End(xlUp).Row
    Set myDataRange = Sheets("Sheet1").Range("D1:D" & lastRow)
    'searching up to the second row (below the field name assumed to be in row 1)...you may need to adjust where the loop stops
    For iCounter = myDataRange.Cells.Count To 2 Step -1
        With myDataRange
            If WorksheetFunction.CountIf(myDataRange, myDataRange.Item(iCounter)) > 1 Then
                Set myDuplicate = .Find(What:=myDataRange.Item(iCounter), After:=myDataRange.Item(iCounter), SearchDirection:=xlPrevious)
                Range("D" & myDuplicate.Row).ClearContents
            End If
        End With
    Next iCounter
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SortFields.Clear
        .SortFields.Add Key:=myDataRange.Offset(1, 0)
        .SetRange myDataRange
        .Header = xlYes
        .Apply
    End With
End Sub

Answer 3

Редактировать: теперь игнорирует пробелы

Редактировать: Изменено, чтобы иметь возможность изменять начальную строку

Что вы можете сделать, это перетащить данные вмассив и поиск в массиве дубликатов.Excel может обрабатывать массивы намного быстрее, чем он может проходить через каждую ячейку.

Следующий код делает именно это.Он оставит D1 в покое (например, в коде вашего примера) и удалит всю строку любых дубликатов, оставив только последний элемент.

Чтобы удалить строки, мы добавим все дубликаты вДиапазон объекта с именем rngDelete и удалить все строки сразу.Это заставит его работать намного быстрее, чем удалять по одному.

Sub Row_Dupe_Killer_Keep_Last()
    Dim vData As Variant
    Dim rngDelete As Range
    Dim lrow As Long, lrowSearch As Long
    Dim lStartRow as long

    'Change this to the row you wish to start with (the top row)
    lStartRow = 22

    'Get all of the data from the cells into a variant array
    'Normally I would prefer to use usedrange, but this method is fine
    '(Note: Change the 2 to 1 if you want to include the entire column including Row number 1)
    vData = Range(Cells(lStartRow, "D").Address & ":" & Cells(Rows.Count, "D").End(xlUp).Address)

    'Search for duplicates
    'First, loop through backwards one by one
    For lrow = UBound(vData) To LBound(vData) Step -1
        'now loop through forwards (up to the point where we have already looked)
        For lrowSearch = LBound(vData) To lrow
            'Check if we have a duplicate
            If Not IsError(vData(lrow, 1)) And Not IsError(vData(lrowSearch, 1)) Then
                If lrow <> lrowSearch And vData(lrow, 1) = vData(lrowSearch, 1) And vData(lrow, 1) <> "" Then
                    'We have a duplicate! Let's add it to our "list to delete"
                    If rngDelete Is Nothing Then
                        'if rngDelete isn't set yet...
                        Set rngDelete = Range("D" & lrowSearch + lStartRow-1)
                    Else
                        'if we are adding to rngDelete...
                        Set rngDelete = Union(rngDelete, Range("D" & lrowSearch + lStartRow-1))
                    End If
                End If
            End If
        Next lrowSearch
    Next lrow

    'Delete all of the duplicate rows
    If Not rngDelete Is Nothing Then
        rngDelete.EntireRow.Delete
    End If
End Sub