how to remove duplicate row based on a column value-CodePudding

I have below sheet where column B has server names repeated two times, some time many times or not repeated at all. Corresponding column C has size which could be same or less or different number or all have same number. I want to delete all dups row leaving behind one row which has bigger number in Column C or same ( If all has same number). I tried to loop thru with below code

Option Explicit
Sub removeDups()
Dim NumberOfValues, counter As Integer
Dim name, foundname As String
Dim value1 As Long
Dim i As Long

NumberOfValues = ThisWorkbook.Sheets("Sheet1").Range("B1").End(xlDown).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 1 To NumberOfValues
            
            name = Range("B" & i).Value
            value1 = Range("C" & i).Value
            foundname = True
            counter = 1
            If counter > 1 Then
                 'don't know how to loop'
            End If
     

Next
Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True
End Sub

CodePudding user response：

Remove Duplicates With Lesser Value

Loops through the column of the keys (B) and if they are not already in the dictionary, adds them, as the keys, and the reference to the associated value cells (C), as the items, to it.
If they are already added, then it checks the current value (C) against the previous value of the item (which is a one-cell range).
Whichever is greater, remains, or gets set as the dictionary item, while the other one is combined into the delete range.
Finally, the delete range's entire rows are deleted in one go.

Option Explicit

Sub RemoveDupesLess()
    
    Const fRow As Long = 1
    Const uCol As String = "B"
    Const vCol As String = "C"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    Dim urg As Range: Set urg = ws.Cells(fRow, uCol).Resize(lRow - fRow   1)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim drg As Range, uCell As Range, vCell As Range
    Dim uKey As Variant, vKey As Variant
    
    For Each uCell In urg.Cells
        uKey = uCell.Value
        Set vCell = uCell.EntireRow.Columns(vCol)
        vKey = vCell.Value
        If Not IsError(uKey) Then
            If Len(uKey) > 0 Then
                If IsNumeric(vKey) Then
                    If dict.Exists(uKey) Then ' unique name exists
                        If dict(uKey).Value < vKey Then ' the value is greater
                            Set drg = RefCombinedRange(drg, dict(uKey))
                            Set dict(uKey) = vCell
                        Else ' the value is less than
                            Set drg = RefCombinedRange(drg, vCell)
                        End If
                    Else ' new unique name
                        Set dict(uKey) = vCell
                    End If
                End If
            End If
        End If
    Next uCell
                        
    If Not drg Is Nothing Then
        drg.EntireRow.Delete
    End If

    MsgBox "Removed duplicates.", vbInformation

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function

CodePudding user response：

I don't think you need VBA for this. You can just use the standard Remove Duplicates functionality.

Sort your data first to ensure the Value 1 column is sorted descending.

Now remove the duplicates being careful to only compare the first two columns ...

The end result should be what you need ...

CodePudding user response：

You can accomplish this in different ways:

Excel 365:

You may benefit fron UNIQUE and MAXIFS:

Formula in E3 is

 =UNIQUE(A1:B26)

and formula in G3 is

 =MAX.SI.CONJUNTO($C$1:$C$26;$B$1:$B$26;F3;$A$1:$A$26;E3)

Then copy/paste as values and delete original data

Any Excel Version:

You can use Pivot Tables to get the range you want and copy/paste. Just create Pivot Table, Columns A and B into rows section and Column C into Values section and Choose MAX instead of SUM

VBA

Sub test()
Dim LR As Long
Dim IR As Long
Dim i As Long
Dim MyDict As Object
Dim MyKey As Variant
Set MyDict = CreateObject("Scripting.Dictionary")


LR = Range("B" & Rows.Count).End(xlUp).Row
IR = 2 'initial row of data

For i = IR To LR Step 1
    If Not MyDict.Exists(Range("B" & i).Value) Then
        MyDict.Add Range("B" & i).Value, Evaluate("SUMPRODUCT(MAX((B" & IR & ":B" & LR & "=""" & Range("B" & i).Value & """)*C" & IR & ":C" & LR & "))")
    End If
Next i

'destiny of new data
'as example, we start pasting data in row 2 column E
i = IR
For Each MyKey In MyDict
    Range("E" & i).Value = MyKey
    Range("F" & i).Value = MyDict(MyKey)
    i = i   1
Next MyKey

MyDict.RemoveAll
Set MyDict = Nothing

'rest of code to delete data or whatever


End Sub

CodePudding user response：

answer from VBasic2008 helped.