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]

I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with. It will generally get you faster results.

See if this does what you want. Assumes cells G2:G3 are empty - but could be any other vertical pair of cells.

Sub ReoveDuplicateIDRows()
  Dim rDupes As Range
 
  Range("G3").Formula = "=ISNUMBER(MATCH(B3,B$2:B2,0))"
  With Range("B2:E22")
    .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

 

[Chewyhairball]

I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with. It will generally get you faster results.

See if this does what you want. Assumes cells G2:G3 are empty - but could be any other vertical pair of cells.

Sub ReoveDuplicateIDRows()
  Dim rDupes As Range
 
  Range("G3").Formula = "=ISNUMBER(MATCH(B3,B$2:B2,0))"
  With Range("B2:E22")
    .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

Hi Peter. I have not had a chance to look at the code yet but as soon as I do I will let you know if it works.

thanks

Rory

 

[Chewyhairball]

As for XL2BB I cannot send anything, other than a screenshot of some random made up data, from a works PC.

 

[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
View attachment 69562 to this View attachment 69563

Hi
This code doesn't remove all of them. It leaves on. For the example above it removes the bottom 2 with ID 4 but leaves the top one.
I tried it with 4 ID's the same but same results. I would like it to remove all of them like in my example above.

thanks

Rory

 

[Peter_SSs]

Yes, sorry, I missed that in the original images. Try this one instead.

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

 

[Chewyhairball]

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

Perfect!!
thanks very much

 

[Fluff]

Note then marking a post as the solution, please mark the post that contains the solution (not your own post saying it worked).
When a post is marked as the solution, it is then shown right underneath the original question, so people viewing the question can easily see the question and solution in a single quick glance without having to hunt through all the posts.

 

[Chewyhairball]

Note then marking a post as the solution, please mark the post that contains the solution (not your own post saying it worked).
When a post is marked as the solution, it is then shown right underneath the original question, so people viewing the question can easily see the question and solution in a single quick glance without having to hunt through all the posts.

The post with the solution is marked?!

 

[Fluff]

I changed it as you had marked your own post as the solution.