Retrieve value in group of values

[danlu]

Hi,

I need a mechanism that retrieves one value from each group depending how the values are ranked within each group(I want the lowest ranked value within each group). This is easiest illustrated by an example (please excuse the look of the columns they are not exactly straight here....):
5 1 25
78 2 25
12 3 25
8 4 30
65 5 30
6 6 30

In the column to the right you have each group (here two groups: the 25-group and the 30-group), in the middle column you find the ranking within each group and in the left column you have the actual values in each group. So in the example above excel should retrieve the values 5 and 8 since they have the lowest ranking in group 25 and group 30 respectively.

Any ideas are highly appreciated.

[lucas]

6 is lower in the 30 group....?

[SamT]

The below is only pseudo Code. Do not try to use it as is.

SamT



' Ranges := ValueCell, RankCell, GroupCell
'Vars := GroupCounter, ChosenValue, LowestRank, MaxValue

Let Vars = 0
Let MaxValue= Rank_Column.HighestValue +1
LowestRank = MaxValue

'CheckLoop
While GroupCell <> End

CurrentGroupCell = GroupCell.OffSet(GroupCounter,0)
ValueCell = CurrentGroupCell.OffSet(0,-2)
RankCell = CurrentGroupCell.Offset(0,-1)


If RankCell < LowestRank Then ChosenValue= ValueCell

'Incrementing GroupCounter
If GroupCell.OffSet(GroupCounter + 1,0).Value = GroupCell.Value Then
GroupCellCounter = GropupCellCounter + 1
Else
Print ChosenValue
let ChosenValue= 0
Let LowestRank = MaxValue

GroupCell.OffSet(GroupCounter,0).Select
GroupCounter = 0
End If
Loop

[jindon]

Hi,

I need a mechanism that retrieves one value from each group depending how the values are ranked within each group(I want the lowest ranked value within each group). This is easiest illustrated by an example (please excuse the look of the columns they are not exactly straight here....):
5 1 25
78 2 25
12 3 25
8 4 30
65 5 30
6 6 30

In the column to the right you have each group (here two groups: the 25-group and the 30-group), in the middle column you find the ranking within each group and in the left column you have the actual values in each group. So in the example above excel should retrieve the values 5 and 8 since they have the lowest ranking in group 25 and group 30 respectively.

Any ideas are highly appreciated.
Isn't it 6 for group 30?

Sub test()
Dim r As Range
With CreateObject("scripting.dictionary")
For Each r In Range("c1", Range("c" & Rows.Count).End(xlUp))
If Not IsEmpty(r) Then
If Not .exists(r.Value) Then
.Add r.Value, r.Offset(, -2).Value
Else
.Item(r.Value) = WorksheetFunction.Min(.Item(r.Value), r.Offset(, -2).Value)
End If
End If
Next
x = .keys: y = .items
End With
For i = 0 To UBound(x)
txt = txt & "Group of " & x(i) & " : " & y(i) & vbLf
Next
If Len(txt) Then MsgBox txt
End Sub

[Bob Phillips]

=INDEX(A1:A6,MATCH(MIN(IF(C1:C6=25,B1:B6)),B1:B6,0))

which is an array formula, it should be committed with Ctrl-Shift-Enter, not just Enter.

[danlu]

No for group 30 it is 8 that should be retrieved since 8 has the lowest ranking (4) within group 30. (6 has the highest ranking (6) in group 30.)

[Bob Phillips]

That is what my solution gives!

[jindon]

OK
understood what you wanted to do

Sub test()
Dim r As Range, w(), x, y
With CreateObject("scripting.dictionary")
For Each r In Range("c1", Range("c" & Rows.Count).End(xlUp))
If Not IsEmpty(r) Then
If Not .exists(r.Value) Then
.Add r.Value, Array(r.Offset(, -2).Value, r.Offset(,-1).Value)
Else
w = .item(r.Value)
If r.Offset(,-1).Value < w(1) Then
w(0) = r.Offset(,-2).Value : w(1) = r.Offset(,-1).Value
End If
.item(r.Value) = w
End If
End If
Next
x = .keys: y = .items
End With
For i = 0 To UBound(x)
txt = txt & "Group of " & x(i) & " : " & y(i)(0) & vbLf
Next
If Len(txt) Then MsgBox txt
End Sub

[danlu]

Hi Jidon,

To easily use this code for a user not accustomed with VBA do you think this sub procedure could be combined with a function so it could be easily run from an excelsheet, or is there some other easy way to run a sub procedure from an excelsheet?

I am not very familiar with CreateObject, do you know some good info source about this so I can learn a bit more about it and how it works.

Thanks a lot for the code already posted! Hope to be able to use it in the near future.

[jindon]

OK
Select one cell in the range and run the code

Sub test()
Dim r As Range, w(), x, y, rng As Range
If ActiveCell.CurrentRegion.Columns.Count <> 3 Then Exit Sub
Set rng = ActiveCell.CurrentRegion.Resize(,3)
With CreateObject("scripting.dictionary")
For Each r In Range(rng.Columns(3).Address)
If Not IsEmpty(r) Then
If Not .exists(r.Value) Then
.Add r.Value, Array(r.Offset(, -2).Value, r.Offset(,-1).Value)
Else
w = .item(r.Value)
If r.Offset(,-1).Value < w(1) Then
w(0) = r.Offset(,-2).Value : w(1) = r.Offset(,-1).Value
End If
.item(r.Value) = w
End If
End If
Next
x = .keys: y = .items
End With
With rng.Offset(,rng.Columns.Count + 2).Resize(,1)
.CurrentRegion.ClearContents
For i = 0 To UBound(x)
.Offset(i).Value = x(i)
.Offset(i,1).Resize(,2).Value = y(i)
Next
End With
Set rng = Nothing
End Sub
Following is a function

select any 2 columns with few rows
and enter
=danlu(A1:c10)
confirm with Ctrl + Shift + Enter (array forumla)

Function danlu(rng As Range)
Dim a(), r As Range, i As Long, n As Long, t As Long
With CreateObject("Scripting.Dictionary")
For i = 1 To rng.Rows.Count
If Not IsEmpty(rng.Cells(i,1)) Then
If Not .exists(rng.Cells(i,1).Value) Then
n = n + 1 : ReDim Preserve a(1 To 3, 1 To n)
dic.add rng.Cells(i,1).Value, n
End If
t = .item(rng.Cells(i,1).Value
a(1, t) = rng.Cells(i,1).Value : a(2,t) = rng.Cells(i,2).Value
If a(3, t) > rng < rng.Cells(i,3).Value Then
a(2, t) = rng.Cells(i,2).Value : a(3,t) = rng.Cells(i,3).Value
End If
End If
End With
End With
danlu = WorksheetFunction.Transpose(a)
End Function
HTH

[danlu]

Hi Jindon,

I have tried out the code but haven't quite managed to make it work.
To make it simpler I have tried to do it in two steps. First two make the sub test work and then the function danlu.(And therefore I focus on step one in this reply). When I run the sub test it works fine for the first group but for the second it finds the value with the lowest ranking within this group (good) but this result is shown as many times as their are values within the previous group plus the the number of times their are values in group two. So if my material looks as below:
5 1 10
2 2 10
1 3 10
5 4 10
7 6 9
8 7 9
9 8 9
10 9 9

The result will be the following:
10 5 1
9 7 6
9 7 6
9 7 6
9 7 6
9 7 6
9 7 6
9 7 6
9 7 6

That is, the retrieved value from the second group (with group no 9) which is value 7 is shown several times.
Any idea how to solve this is of great value!

[jindon]

OK
Let's see if this works

Sub test()
Dim r As Range, w(), x, y, rng As Range
If ActiveCell.CurrentRegion.Columns.Count <> 3 Then Exit Sub
Set rng = ActiveCell.CurrentRegion.Resize(,3)
With CreateObject("scripting.dictionary")
For Each r In Range(rng.Columns(3).Address)
If Not IsEmpty(r) Then
If Not .exists(r.Value) Then
.Add r.Value, Array(r.Offset(, -2).Value, r.Offset(,-1).Value, 1)
Else
w = .item(r.Value)
If r.Offset(,-1).Value < w(1) Then
w(0) = r.Offset(,-2).Value : w(1) = r.Offset(,-1).Value : w(2) =1
ElseIf r.Offset(,-1).Value = w(1) Then
w(2) = w(2) + 1
End If
.item(r.Value) = w
End If
End If
Next
x = .keys: y = .items
End With
With rng.Offset(,rng.Columns.Count + 2).Resize(,1)
.CurrentRegion.ClearContents
For i = 0 To UBound(x)
.Offset(i).Resize(y(i)(2)).Value = x(i)
.Offset(i,1).Resize(y(i)(2),2).Value = y(i)
Next
End With
Set rng = Nothing
End Sub

[danlu]

Great! Now it works much better. A small cosmetic thing, how do I rearange the result columns so that they are shown from left to right in the following order:
retrieved value column, ranking column, group column
(Now they are shown as group column, rerieved value column, ranking column)