Excel 2016 VBA删除具有特定条件的行

Question

I have the following data.

If the same task appears more than 2 rows, I need to delete the 3rd, 4th,...duplicate rows. The rows are already sorted by Task name and date modified. I only need the most current and 1 prior data (first 2 rows of the same task).

In the above image, Row 7, 8, 9, 13, 14, 15, 16, 17, ... should be deleted

Answer 1

This isn't as easy to pull of as it first seems it might be. Every time we loop rows and delete the row based on some criteria we run into issues. We delete the row we are on, and then move to the next row, but because we deleted the row we are on, we are already on the next row. It's like pulling the rug out from underneath us while we are walking.

To get around these we usually step backwards through a range and delete, but... because in this case we are only deleting based on what we've already found, we have to go forwards.

There's a few ways to deal with this. I think the safest and most robust way is by looping once to get a count of each term, then looping again and deleting the appropriate amount of rows based on what we found in the first loop. This way we have LOTS of control over what gets deleted and how far we step in each iteration. It also reduces the complexities that we would face in tracking what we've found, how much of it, if we need to delete the current row, and how to deal with the loop if we do.

Sub removeRows()
    Dim rngRow As Range
    Dim dictTerms As Scripting.Dictionary

    'Initialize Dictionary
    Set dictTerms = New Scripting.Dictionary

    'Load up dictionary using the term as the key and the count as the value
    ' by looping through each row that holds the terms
    For Each rngRow In Sheet1.Rows("3:17")
        'Only upsert to dictionary if we have a valule
        If rngRow.Cells(1, 1).Value <> "" Then
            If dictTerms.Exists(rngRow.Cells(1, 1).Value) Then
                'increment value
                dictTerms(rngRow.Cells(1, 1).Value) = dictTerms(rngRow.Cells(1, 1).Value) + 1
            Else
                'Add to dictionary with value 1
                dictTerms.Add Key:=rngRow.Cells(1, 1).Value, Item:=1
            End If
        End If
    Next rngRow

    Dim intRow As Integer: intRow = 3
    Dim intCounter As Integer
    Dim termCount As Integer

    'Loop through rows starting at intRow(set to 3 above) and ending at 17 (possible max)
    Do While intCounter <= 17

        'Skip blank rows
        If Sheet1.Cells(intRow, 1).Value <> "" Then

            'grab the number of terms encounterd so we know how much to delete
            termCount = dictTerms(Sheet1.Cells(intRow, 1).Value)

            'If it's more than two, then delete the remaining
            If termCount > 2 Then Sheet1.Rows(intRow + 2 & ":" & intRow + termCount - 1).Delete

            'Increment past what we deleted (or found if we didn't delete anything)
            intRow = intRow + 2 + (termCount <> 1)

            'Set the loop counter.
            intCounter = intCounter + termCount

        Else
            'We found a blank, just increment our loop counter
            intCounter = intCounter + 1
            intRow = intRow + 1
        End If
    Loop

End Sub

You'll need to go to Tools>>References and add Microsoft Scripting Runtime (check the checkbox next to it in the big list and hit OK) so we can use the Scripting.Dictionary.

You'll also need to edit references to Sheet1 to whatever Sheet you are on. And possibly references to Cells(1,1) changing that first 1 to whatever column we are analyzing (assumed Column "A" here). Lastly you'll need to tweak startRow and endRow setting those values to whatever is appropriate for you workbook.

Answer 2

@JNevill, when you mentioned counter for each task, I just thought of something simple, -- now I just need to figure out how to delete the rows with values greater than 2 in the new column...without getting the error Script out of Range or Delete Method of Range Class Failed

'Declare Variables
    Dim tableName As String
    Dim activeSheetName As String
    Dim totalrows As Long


'Identify Active Sheet Name
    activeSheetName = ActiveSheet.Name

'Identify Active Table Name
    tableName = ActiveSheet.ListObjects(1).Name

'Identify total number of rows
    totalrows = Worksheets(activeSheetName).Range(tableName).Rows.count '99

'Insert counter column
Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Dim taskCounter As Long
Dim rowNum As Integer
rowNum = 2
taskCounter = 0

For a = 1 To totalrows + 1

    If Range("A" & rowNum) = "" Then
        taskCounter = 0
        Range("B" & rowNum).Value = taskCounter
    Else
        taskCounter = taskCounter + 1
        Range("B" & rowNum).Value = taskCounter
    End If

    rowNum = rowNum + 1
Next a