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.
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.
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!
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.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.