Add another item to dictionary items

[YasserKhalil]

Hello everyone
I have this code

Code: Select all

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

    Set rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))

    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each cl In rng
            If Not .Exists(cl.Value) Then
                .Add cl.Value, cl(, 2)
            Else
                .Item(cl.Value) = Application.Max(.Item(cl.Value), cl(, 2))
            End If
        Next cl
        Range("J1").Resize(.Count, 3) = Application.Transpose(Array(.Keys, .Items))
    End With
End Sub

It works fine for two columns ..
First for the unique values (KEYS) and the the other column is the adjacent column for the maximum value
I need to add another column which is column D .. which has the value adjacent to the maximum value in column C
How can I add the items of the third column

[HansV]

For example:

Code: Select all

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")
    With d
        .CompareMode = vbTextCompare
        For Each cl In rng
            If Not .Exists(cl.Value) Then
                .Add cl.Value, cl.Offset(0, 1).Resize(1, 2)
            Else
                .Item(cl.Value)(1) = Application.Max(.Item(cl.Value)(1), cl.Offset(0, 1))
                .Item(cl.Value)(2) = Application.Max(.Item(cl.Value)(2), cl.Offset(0, 2))
            End If
        Next cl
        Range("J1").Resize(.Count, 1) = Application.Transpose(.Keys)
        Range("J1").Offset(0, 1).Resize(.Count, 2) = Application.Transpose(Application.Transpose(.Items))
    End With
End Sub

[YasserKhalil]

Thanks a lot
I have noticed that the original data changed in values .. I don't need to change the original data .. Just to extract the unique items and the maximum value from column C and the related value in column D
example :
change the value in C13 to 2000 and notice the value in C10 after running the code

[HansV]

Here is a new attempt:

Code: Select all

Sub Test()
    Dim rng         As Range
    Dim cl          As Range
    Dim d1          As Object
    Dim d2          As Object

    Set rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))

    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")

    d1.CompareMode = vbTextCompare
    d2.CompareMode = vbTextCompare
    For Each cl In rng
        If Not d1.Exists(cl.Value) Then
            d1.Add cl.Value, cl(, 2)
            d2.Add cl.Value, cl(, 3)
        Else
            d1.Item(cl.Value) = Application.Max(d1.Item(cl.Value), cl(, 2))
            d2.Item(cl.Value) = Application.Max(d2.Item(cl.Value), cl(, 3))
        End If
    Next cl
    Range("J1").Resize(d1.Count) = Application.Transpose(d1.Keys)
    Range("K1").Resize(d1.Count) = Application.Transpose(d1.items)
    Range("L1").Resize(d2.Count) = Application.Transpose(d2.items)
End Sub

[HansV]

By the way, a pivot table would do what you want.

[YasserKhalil]

Thanks a lot.
Please have a look at the attachment

[HansV]

I'm sorry, I didn't read your request carefully enough. I calculated the max of column D instead of the value adjacent to the max in column C.

Code: Select all

Sub Test()
    Dim rng         As Range
    Dim cl          As Range
    Dim d1          As Object
    Dim d2          As Object

    Set rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))

    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")

    d1.CompareMode = vbTextCompare
    d2.CompareMode = vbTextCompare
    For Each cl In rng
        If Not d1.Exists(cl.Value) Then
            d1.Add cl.Value, cl(, 2)
            d2.Add cl.Value, cl(, 3)
        ElseIf cl(, 2) > d1.Item(cl.Value) Then
            d1.Item(cl.Value) = cl(, 2)
            d2.Item(cl.Value) = cl(, 3)
        End If
    Next cl
    Range("J1").Resize(d1.Count) = Application.Transpose(d1.Keys)
    Range("K1").Resize(d1.Count) = Application.Transpose(d1.items)
    Range("L1").Resize(d2.Count) = Application.Transpose(d2.items)
End Sub

[YasserKhalil]

That's great. Thanks a lot for great help. That worked well
I thought there is a way to use one object of dictionary to do the whole task instead of creating another instance of a dictionary

[HansV]

Probably, but this was easier.

[HansV]

Here is a version that uses only one dictionary:

Code: Select all

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

    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

[YasserKhalil]

That's wonderful and great. Thank you very very much for fantastic help