Lookup value and show all corresponding values in one cell

[charleymax]

Hi all,

Many apologies if this is easy but I seem to have struggled with it for hrs now...

I have a data set where I want to have a column that looks up a document number and shows me in one cell all the project numbers it is linked to...
If the document only shows up once for one project I want it to state None...

So A1 looks up C1's value i.e. Doc 1234 and sees that through all of Col B it is listed as involved in the MSG, PPP and ZyD projects... So in A it would return MSG, PPP,ZyD...

Want it to look like this

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG03Mar25
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q, K
[COLOR="Navy"]Dim[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C2"), Range("c" & rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.value) [COLOR="Navy"]Then[/COLOR]
            n = n + 1
            .Add Dn.value, Array(n, Dn.Offset(, -1), Dn.Offset(, -2).Address)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Dn.value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -1)
            Q(2) = Q(2) & ", " & Dn.Offset(, -2).Address
            .Item(Dn.value) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
[COLOR="Navy"]Set[/COLOR] Rng = Range(.Item(K)(2))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Rng
        R = IIf(InStr(.Item(K)(1), ",") > 1, .Item(K)(1), "None")
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[charleymax]

Hi MickG,

Thanks a million... I just need a few pointer on where to put the code and how to call it in the cells I want the crossover list to appear...?
I have put it in the view code section of the tab I'm working in.
When I change the Doc # in a cell it recalculates but I'm not seeing anything being updated...

Also my Doc# column is actualy col J and There may be one or two columns between, so projects in E and crossover in B... Do I just need to edit the Range and Dn.offsets to -5 or -8 etc..

Sub MG03Mar25()
Dim Rng As Range, Dn As Range
Dim n As Long
Dim Q, K
Dim R As Range
Set Rng = Range(Range("J2"), Range("j" & Rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        With CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            n = n + 1
            .Add Dn.Value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        Else
            Q = .Item(Dn.Value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.Value) = Q
        End If
    Next
For Each K In .keys
Set Rng = Range(.Item(K)(2))
    For Each R In Rng
        R = IIf(InStr(.Item(K)(1), ",") > 1, .Item(K)(1), "None")
    Next R
Next K
End Sub

 

[charleymax]

Ok, I got it to work if I put it in the Worksheet_Change(ByVal Target As Range)

Works a beauty but Problem is eventually it comes up with a Run Time error 1004 'Out of Stack Space'

Is there any way of simplifying the calculation so I can run a full calculation first time or now and again through calling a full macro but have a simpler worksheet_change version that only recalculates for rows where the Doc # is the same as the one I just updated... if that is doable...

Apologies for complicating things!

 

[MickG]

Hi, Your probably got this, but just to recap.
This is a double click event for "A1" (Docs =Column"J", Projects=Column "E", CrossOver=Column"B")
Right click sheet tab , Select "View Code", VB window appears.
Paste code into VB Window, Close VB window.
To run Code , Double Click "A1.

Ref your short Macro Idea.
Do you mean you enter another doc number in Column "J" along with its related inf in the same row, then you run the New (Short) Code, which will only update information for that number.
Please confirm, or clarify.

[COLOR=navy]Sub[/COLOR] MG04Mar03
Private [COLOR=navy]Sub[/COLOR] Worksheet_BeforeDoubleClick(ByVal Target [COLOR=navy]As[/COLOR] Range, Cancel [COLOR=navy]As[/COLOR] Boolean)
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Q, K
[COLOR=navy]Dim[/COLOR] R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]If[/COLOR] Target.Address(0, 0) = "A1" [COLOR=navy]Then[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("J2"), Range("J" & rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.value) [COLOR=navy]Then[/COLOR]
            n = n + 1
            .Add Dn.value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Dn.value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.value) = Q
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
[COLOR=navy]Set[/COLOR] Rng = Range(.Item(K)(2))
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Rng
        R = IIf(InStr(.Item(K)(1), ",") > 0, .Item(K)(1), "None")
    [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

Please Note:-
The first line of code "Sub MG04Mar03" , should not be there, please remove before installing, Sorry.
Mick

 

[charleymax]

Hey Mick...

ok... This looks like a great solution and should kill that stack overload error I was getting. Problem is now I'm seeing another runtime error 1004... This time it says:
Method 'Range' of Object '_Worksheet' failed...

debug stops on this line...

Set Rng = Range(.Item(K)(2))

 

[MickG]

Can you post the data it failed on.
Also If you Place a Border around each cell in the range you wish to post , so that it forms a grid, then Copy and paste to the forum, I will be able to copy this to my sheet.
If you paste a Picture I can't copy it.
Regards Mick

 

[charleymax]

Can you post the data it failed on.
Also If you Place a Border around each cell in the range you wish to post , so that it forms a grid, then Copy and paste to the forum, I will be able to copy this to my sheet.
If you paste a Picture I can't copy it.
Regards Mick

Hi Mick,

You peaked my curiosity on what it might fail on... it was blanks. This couldn't handle blans in Colm J... can the VBA be amended to ignore blanks in Column J.?

So what I'm saying is it works perfectly if I start fresh with just 20 or 30 rows... Also When I deleted any with blanks in J it still worked even with over 1000 rows...

 

[MickG]

Try this:-
Funnily enough when I placed Blank rows in "J" in did not fail it just returned "," which I would have expect.
This is written in Excel 2003, What are you ???

Private [COLOR=navy]Sub[/COLOR] Worksheet_BeforeDoubleClick(ByVal Target [COLOR=navy]As[/COLOR] Range, Cancel [COLOR=navy]As[/COLOR] Boolean)
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Q, K
[COLOR=navy]Dim[/COLOR] R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]If[/COLOR] Target.Address(0, 0) = "A1" [COLOR=navy]Then[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("J2"), Range("J" & rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        [COLOR=navy]If[/COLOR] Dn <> "" [COLOR=navy]Then[/COLOR]
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.value) [COLOR=navy]Then[/COLOR]
            n = n + 1
            .Add Dn.value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Dn.value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.value) = Q
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
[COLOR=navy]Set[/COLOR] Rng = Range(.Item(K)(2))
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Rng
        R = IIf(InStr(.Item(K)(1), ",") > 0, .Item(K)(1), "None")
    [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick