Delete and shift cells up

[Chewyhairball]

Hi folks

Looking for VBA to find duplicate values in ID column and delete them by shifting cells up. (not deleting whole row). Thanks

Example below is what I want.

Actual table range will be B2:E22

to this

 

[Peter_SSs]

Also, when quoting code from a previous post, please ensure that you select the code heading at the top as well as the code itself

That way the code will appear correctly laid out and readable as below (when expanded if required) instead of the virtually impossible to read code as in your post #7

VBA Code:

Sub ReoveDuplicateIDRows_2()
  Dim rDupes As Range
 
  With Range("B2:E22")
    Range("G3").Formula = "=COUNTIF(" & .Columns(1).Address & "," & .Cells(2, 1).Address(0, 0) & ")>1"
    .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("G2:G3"), Unique:=False
    If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
      Set rDupes = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
      .Parent.ShowAllData
      rDupes.Delete Shift:=xlUp
    Else
      .Parent.ShowAllData
    End If
    Range("G3").ClearContents
  End With
End Sub