Remove Duplicate (Sort of) Row based on => Value in another Cell

[slpswhite]

I need to add this to a Macro I am working on and this one is beating me right now. Any help is much appreciated.

These are columns B,C,D and E in my spreadsheet.

What I am trying to accomplish is if there is a duplicate value in column "B" to evaluate the numbers in column "E". If the numbers are equal to or greater then the duplicate in column "B", delete the entire row of the lessor value in column "E" or one of the rows which is equal to in column "E"

These are all dups from my spreadsheet as you can see they are not always one right after the other. I am not opposed to sorting the list in any way shape or form.

[TABLE="width: 823"]
<tbody>[TR]
[TD]UIMK79[/TD]
[TD]IBM Offshore[/TD]
[TD="align: right"]11/24/2017[/TD]
[TD="align: right"]100[/TD]
[/TR]
[TR]
[TD]UIMK79[/TD]
[TD]IBM Offshore[/TD]
[TD="align: right"]11/17/2017[/TD]
[TD="align: right"]100[/TD]
[/TR]
[TR]
[TD]UGJS341[/TD]
[TD]Infosys Onshore[/TD]
[TD="align: right"]11/17/2017[/TD]
[TD="align: right"]49[/TD]
[/TR]
[TR]
[TD]UISS132[/TD]
[TD]IBM Offshore[/TD]
[TD="align: right"]11/17/2017[/TD]
[TD="align: right"]48[/TD]
[/TR]
[TR]
[TD]UGRS275[/TD]
[TD]Principle Solution Group[/TD]
[TD="align: right"]11/18/2017[/TD]
[TD="align: right"]49[/TD]
[/TR]
[TR]
[TD]UGRS275[/TD]
[TD]Principle Solution Group[/TD]
[TD="align: right"]11/18/2017[/TD]
[TD="align: right"]50[/TD]
[/TR]
[TR]
[TD]UGDB160[/TD]
[TD]Infosys Onshore[/TD]
[TD="align: right"]11/17/2017[/TD]
[TD="align: right"]48.5[/TD]
[/TR]
[TR]
[TD]UGSA164[/TD]
[TD]Cognizant Onshore[/TD]
[TD="align: right"]11/17/2017[/TD]
[TD="align: right"]45[/TD]
[/TR]
</tbody><colgroup><col><col><col><col></colgroup>[/TABLE]

 

[SteveO59L]

have you considered a pivot table?

 

[slpswhite]

I had but this is part of a much larger project I am working on and it would be best if I could do this using VBA. I have many more columns of information in the table this was just a little snippet.

 

[Fluff]

How about

Sub RemoveDupes()

   Dim Rng As Range
   Dim Cl As Range
   Dim Itm As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 3)
         ElseIf .Item(Cl.Value).Value < Cl.Offset(, 3).Value Then
            Set .Item(Cl.Value) = Cl.Offset(, 3)
         End If
      Next Cl
      Set Rng = Range("E1")
      For Each Itm In .items
         Set Rng = Union(Rng, Itm)
      Next Itm
   End With
   Rng.EntireRow.Hidden = True
   With ActiveSheet
      .UsedRange.SpecialCells(xlVisible).EntireRow.Delete
      .Cells.Rows.Hidden = False
   End With
   
End Sub

 

[slpswhite]

Fluff you are magic!!! Thanks so much!

 

[Fluff]

Glad to help & thanks for the feedback

 

[slpswhite]

Fluff the code works great, however, as always there is always one more thing! This is part of a request system and a user can request to work a number of extra hours. I need to view these records as a week and if I have a match in column B for the same week I need to delete any other requests for the same week which are equal to or less than the largest request in column E.

Is there a way for this to look at a calendar to determine the weeks as we move forward?

 

[Fluff]

Try

Sub RemoveDupes()

   Dim Rng As Range
   Dim Cl As Range
   Dim Itm As Variant
   Dim WkNum As Long
   Dim ValU As String
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
         WkNum = WorksheetFunction.WeekNum(Cl.Offset(, 2).Value, 2)
         ValU = Cl.Value & WkNum
         If Not .exists(ValU) Then
            .Add ValU, Cl.Offset(, 3)
         ElseIf .Item(ValU).Value < Cl.Offset(, 2).Value Then
            Set .Item(ValU) = Cl.Offset(, 3)
         End If
      Next Cl
      Set Rng = Range("E1")
      For Each Itm In .items
         Set Rng = Union(Rng, Itm)
      Next Itm
   End With
   Rng.EntireRow.Hidden = True
   With ActiveSheet
      .UsedRange.SpecialCells(xlVisible).EntireRow.Delete
      .Cells.Rows.Hidden = False
   End With
   
End Sub

 

[slpswhite]

Hey Fluff the code works great thanks again. I had to reorder the columns and when I did a one for one change to the code I now receive an Unable to get WeekNum property of the WorksheetFuntion class error.

Here is what changed:

Name Old Column New Column
ID B D
Vendor C B
Date D E
Number E G

The code as I changed it:

Sub RemoveDupes()
   Dim Rng As Range
   Dim Bl As Range
   Dim Itm As Variant
   Dim WkNum As Long
   Dim ValU As String
   
   With CreateObject("scripting.dictionary")
      For Each Bl In Range("D2", Range("D" & Rows.Count).End(xlUp))
         WkNum = WorksheetFunction.WeekNum(Bl.Offset(, 2).Value, 2)
         ValU = Bl.Value & WkNum
         If Not .exists(ValU) Then
            .Add ValU, Bl.Offset(, 3)
         ElseIf .Item(ValU).Value < Bl.Offset(, 2).Value Then
            Set .Item(ValU) = Bl.Offset(, 3)
         End If
      Next Bl
      Set Rng = Range("G1")
      For Each Itm In .items
         Set Rng = Union(Rng, Itm)
      Next Itm
   End With
   Rng.EntireRow.Hidden = True
   With ActiveSheet
      .UsedRange.SpecialCells(xlVisible).EntireRow.Delete
      .Cells.Rows.Hidden = False
   End With
End Sub

What am I missing here?

 

[Fluff]

This

Bl.Offset(, 2)

is looking 2 columns to the right of Bl, so originally Bl was col B, meaning the offset is then looking at col D.
As you have change the col from B to D you'll need to change all the Offsets to match.
Any problems let me know