Excel 2016 VBA Delete Rows with certain criteria - excel

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