maximum Value from other column

[amir0914]

hi all, i have three Columns that There are similar numbers in first column and now, i want to find maximum value for similar number in second column and cell value in third column for maximum weight,,, such as below image. :

Max.jpg

can i do this with vba???? (I hope I have been able to express my question.)

[p45cal]

Supply a workbook with a single sheet being what you've pictured - nobody's going to type out a new sheet to experiment with.

[mana]

Option Explicit


Sub test()
    Dim r As Range
    
    With Cells(1).CurrentRegion
        Set r = .Offset(, .Columns.Count + 2)
        .Copy Destination:=r
    End With
    
    r.Sort key1:=r.Columns(1), order1:=xlAscending, _
            key2:=r.Columns(2), order2:=xlDescending, Header:=xlYes
    r.RemoveDuplicates Columns:=1
        
End Sub

[YasserKhalil]

Another approach

Sub Test()
    Dim d           As Object
    Dim rng         As Range
    Dim cl          As Range


    Set rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = vbTextCompare


    For Each cl In rng
        If Not d.Exists(cl.Value) Then
            d.Add cl.Value, Array(cl(, 2), cl(, 3))
        ElseIf cl(, 2) > d.Item(cl.Value)(0) Then
            d.Item(cl.Value) = Array(cl(, 2), cl(, 3))
        End If
    Next cl


    Range("J1").Resize(d.Count) = Application.Transpose(d.Keys)
    Range("K1").Resize(d.Count, 2) = Application.Application.Transpose(Application.Transpose(d.items))
End Sub

The code is from this link
http://www.eileenslounge.com/viewtopic.php?f=30&t=30272

[amir0914]

hi yasser, thank you so much, i used that code and my problem is resolved but i have tow problems with the code :

1. If there are empty cells in third column, i get below error :

Max5.jpg

2. doesn't add extra zeros form first column, which convert "0000" to "0" or "020" to "20" (remove zeros)

thanks again.

[mana]

Option Explicit


Sub test2()
    Dim r As Range
    
    With Columns("B:D")
        Set r = .Offset(, .Columns.Count + 2)
        .Copy Destination:=r
    End With
    
    r.Sort key1:=r.Columns(1), order1:=xlAscending, _
            key2:=r.Columns(2), order2:=xlDescending, Header:=xlYes
    r.RemoveDuplicates Columns:=1
        
End Sub

[p45cal]

nobody's going to type out a new sheet to experiment with.

I was wrong!

[mana]

2. doesn't add extra zeros form first column, which convert "0000" to "0" or "020" to "20" (remove zeros)

Option Explicit


Sub test3()
    Dim r As Range
    
    With Columns("B:D")
        Set r = .Offset(, .Columns.Count + 2)
        .Copy Destination:=r
    End With


    r.Columns(1).TextToColumns
    r.Sort key1:=r.Columns(1), order1:=xlAscending, _
            key2:=r.Columns(2), order2:=xlDescending, Header:=xlYes
    r.RemoveDuplicates Columns:=1
        
End Sub

[amir0914]

hey mana, big up to you... my problem has been resolved by your help...thanks again.