PDA

View Full Version : [SOLVED] maximum Value from other column



amir0914
07-05-2018, 01:27 AM
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. :

22523

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

p45cal
07-05-2018, 04:35 AM
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
07-05-2018, 05:10 AM
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
07-05-2018, 05:11 AM
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
07-07-2018, 03:47 AM
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 :

22533

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

thanks again.

mana
07-07-2018, 04:07 AM
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
07-07-2018, 04:14 AM
nobody's going to type out a new sheet to experiment with.I was wrong!

mana
07-07-2018, 05:01 AM
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
07-08-2018, 01:03 AM
hey mana, big up to you... my problem has been resolved by your help...thanks again.