VBA: Keep first and last rows of duplicate column values of an Excel sheet

Question

I have an Excel worksheet with 20K rows like this:

header1	header2
1	P
2	P
3	P
4	Q
5	R
6	R
7	R
8	R
9	S
10	S

I want a VBA code to delete the rows containing duplicates, but keep the first and last row of the duplicates. The result should be like this:

header1	header2
1	P
3	P
4	Q
5	R
8	R
9	S
10	S

I have modified the following code found here to do just that, but every time I have to manually select the range containing the duplicates in column header2.

Sub Delete_Dups_Keep_Last_v2()
 Dim SelRng As Range
 Dim Cell_in_Rng As Range
 Dim RngToDelete As Range
 Dim SelLastRow As Long
 
    Application.DisplayAlerts = False
    Set SelRng = Application.InputBox("Select cells", Type:=8)
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    SelLastRow = SelRng.Rows.Count + SelRng.Row - 1
    For Each Cell_in_Rng In SelRng
        
        If Cell_in_Rng.Row < SelLastRow Then
            If Cell_in_Rng.Row > SelRng.Row Then
                If Not Cell_in_Rng.Offset(1, 0).Resize(SelLastRow - Cell_in_Rng.Row).Find(What:=Cell_in_Rng.Value, Lookat:=xlWhole) Is Nothing Then
                    'this value exists again in the range
                    If RngToDelete Is Nothing Then
                        Set RngToDelete = Cell_in_Rng
                    Else
                        Set RngToDelete = Application.Union(RngToDelete, Cell_in_Rng)
                    End If
                End If
            End If
        End If
        
    Next Cell_in_Rng
 
    If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete

End Sub

Another code found here by user A.S.H. automates the manual selection and speed by using Dictionary, but fails to produce the wanted result.

Sub keepFirstAndLast()
  Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '(to not start with a null range)
  Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

  Dim a As Range
  For Each a In Sheet1.Range("B2", Sheet1.Range("B999999").End(xlUp))
    If Not dict.Exists(a.Value2) Then
      dict(a.Value2) = 0 ' first appearence, dont save the row
    Else
      ' if last observed occurrence was a duplicate, add it to deleted range
      If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
      dict(a.Value2) = a.row ' not first appearence, save the row for eventual deletion
    End If
  Next
  toDelete.Delete
End Sub

user_14163839 · Answer

Simple solution:

Sub KeepFirstLast()

Application.ScreenUpdating = False

Dim lastRow As Long
lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
Dim x As Long
Dim currentValue As String

For i = lastRow To 2 Step -1
    If i = 2 Then
        Application.ScreenUpdating = True
        Exit For
    End If
    currentValue = Sheets(1).Cells(i, 2).Value
    x = i - 1
    Do While Sheets(1).Cells(x, 2).Value = currentValue And Sheets(1).Cells(x - 1, 2).Value = currentValue
        Sheets(1).Rows(x).Delete
        x = x - 1
    Loop
    i = x + 1
Next i


Application.ScreenUpdating = True

End Sub

user_9814069 · Answer

Keep First and Last In Sorted Range

Option Explicit

Sub DeleteNotFirstNorLast()
    Const ProcName As String = "DeleteNotFirstNorLast"
    Dim RowsDeleted As Boolean ' to inform
    On Error GoTo ClearError ' enable error trapping
    
    ' Constants (adjust!)
    Const FirstCellAddress As String = "A1"
    Const CriteriaColumnIndex As Long = 2
    Const Criteria As String = "#$%"
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Application.ScreenUpdating = False
    
    ' Remove any filters.
    If ws.FilterMode Then ws.ShowAllData
    
    ' Reference the table range.
    Dim trg As Range: Set trg = RefCurrentRegion(ws.Range(FirstCellAddress))
    
    ' Write an ascending integer sequence adjacent to the right
    ' of the table range.
    AppendColumnOfAscendingIntegers trg
    
    ' Include this helper column to the table range.
    Set trg = trg.Resize(, trg.Columns.Count + 1)
    
    ' Reference the criteria column range.
    Dim crg As Range: Set crg = trg.Columns(CriteriaColumnIndex)
    
    ' It is assumed that the criteria column is already sorted favorably.
    ' If not, you could do something like the following:
    
    ' Sort the table range by the criteria column ascending.
    'trg.Sort crg, xlAscending, , , , , , xlYes
    
    ' Write the data rows (no headers) count to a variable.
    Dim drCount As Long: drCount = trg.Rows.Count - 1
    
    ' Reference the criteria column data range (headers excluded).
    Dim cdrg As Range: Set cdrg = crg.Resize(drCount).Offset(1)
    
    ' Write the values from the criteria column data range to an array.
    Dim cData As Variant: cData = GetRange(cdrg)
    
    ' Replace the unwanted values in the array with the criteria.
    KeepFirstAndLastInColumn cData
    
    ' Write the (modified) values from the array back to the range.
    cdrg.Value = cData
    
    ' Reference the table data range (no headers).
    Dim tdrg As Range: Set tdrg = trg.Resize(drCount).Offset(1)
    
    ' Filter the table range in the criteria column by the criteria.
    trg.AutoFilter CriteriaColumnIndex, Criteria
    
    ' Attempt to reference the table data visible (filtered) range.
    Dim tdvrg As Range
    On Error Resume Next ' defer error trapping
        Set tdvrg = tdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo ClearError ' re-enable error trapping
    
    ' Remove the filter.
    ws.AutoFilterMode = False
    
    ' Attempt to delete the table data visible range.
    If Not tdvrg Is Nothing Then
        tdvrg.Delete xlShiftUp
        RowsDeleted = True
    End If
    
    ' Reference the helper column.
    Dim hrg As Range: Set hrg = trg.Columns(trg.Columns.Count)
    
    ' Sort the table range by the helper column ascending.
    trg.Sort hrg, xlAscending, , , , , , xlYes
    
    ' Clear the helper column.
    hrg.Clear
    
SafeExit:
    Application.ScreenUpdating = True ' to see any changes while reading message
    
    ' Inform.
    If RowsDeleted Then
        MsgBox "Rows deleted.", vbInformation, ProcName
    Else
        MsgBox "Nothing deleted.", vbExclamation, ProcName
    End If

    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume SafeExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with the first cell
'               of a range and ending with the last cell of the first cell's
'               Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefCurrentRegion"
    On Error GoTo ClearError

    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Cells(1).CurrentRegion
        Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
            - FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes an ascending integer sequence adjacent to the right
'               of a range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AppendColumnOfAscendingIntegers( _
        ByVal trg As Range, _
        Optional ByVal FirstInteger As Long = 1)
    Const ProcName As String = "AppendColumnOfAscendingIntegers"
    On Error GoTo ClearError
    
    With trg
        With .Resize(, 1).Offset(, .Columns.Count)
            .Value = .Worksheet.Evaluate("ROW(" & CStr(FirstInteger) & ":" _
                & CStr(FirstInteger + .Rows.Count - 1) & ")")
        End With
    End With

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('trg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal trg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If trg.Rows.Count + trg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = trg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = trg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In the first column of a 2D one-based array of sorted values,
'               keeps the first and last occurrence of each value and replaces
'               the remaining occurrences with a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub KeepFirstAndLastInColumn( _
        ByRef cData As Variant, _
        Optional ByVal Criteria As String = "#$%")
    Const ProcName As String = "KeepFirstAndLastInColumn"
    On Error GoTo ClearError

    Dim OldString As String: OldString = CStr(cData(1, 1))
    
    Dim r As Long
    Dim cr As Long
    Dim FirstRow As Long
    Dim NewString As String
    
    For r = 2 To UBound(cData, 1)
        NewString = CStr(cData(r, 1))
        If NewString = OldString Then
            If FirstRow = 0 Then
                FirstRow = r
            End If
        Else
            If FirstRow > 0 Then
                For cr = FirstRow To r - 2
                    cData(cr, 1) = Criteria
                Next cr
                FirstRow = 0
            End If
            OldString = NewString
        End If
    Next r

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

user_9199828 · Answer

You may benefit from SpecialCells to select those rows based on formula:

Sub test()
Dim LR As Long 'last row
Dim LC As Long 'last column
Dim SR As Long 'starting row
Dim rng As Range

Set rng = Range("A1") 'change this to TOP LEFT CELL OF YOUR DATA

SR = rng.Row
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column 'last column used

'we add new column with formula to delete
With Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1))
    .FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
End With

'clear formula
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1)).Clear

Set rng = Nothing

End Sub

[![enter image description here][1]][1]

The tricky part is here:

.FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete

First line will create and IF(OR) formula to check if the row must be deleted or not. It will return x if not, else 0

Second line will delete entire rows only if it contains a number (zero) [1]: https://i.stack.imgur.com/UlhtI.gif

user_2872922 · Answer

This can also be accomplished using Power Query, available in Windows Excel 2010+ and Excel 365 (Windows or Mac)

To use Power Query

Select some cell in your Data Table
Data => Get&Transform => from Table/Range or from within sheet
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm

M Code

let

//change next line to your actual table name in your worksheet
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"header1", Int64.Type}, {"header2", type text}}),

//Group by header2
// then return the first and last table rows if there is more than a single row
    #"Grouped Rows" = Table.Group(#"Changed Type", {"header2"}, {
        {"header1", each if Table.RowCount(_) = 1 then _ 
            else Table.FromRecords({Table.First(_),Table.Last(_)}), 
                    type table[header1=Int64.Type, header2=text]}
        }),

//expand the subtables and set the column order
    #"Expanded header1" = Table.ExpandTableColumn(#"Grouped Rows", "header1", {"header1"}),
    #"Reordered Columns" = Table.ReorderColumns(#"Expanded header1",{"header1", "header2"})
in
    #"Reordered Columns"

VBA: Keep first and last rows of duplicate column values of an Excel sheet

4 Answers

Keep First and Last In Sorted Range