VBA Macro multiple value lookup

[powerman4912]

Hi all,

I am looking to write a macro to do the following with this set of data:

A123 B123
A123 B124
A123 B125
A124 B126
A125 B127 ... etc

I would like to input:

A123
A124
A125

run the macro... and get back

A123 B123 B124 B125
A124 B126
A125 B127

I've experimented with an index lookup and an indirect reference but it doesn't seem to work well.

Any ideas for a macro?

Thanks for your help.

 

[MickG]

This will give results for all Items in first column :-

[COLOR="Navy"]Sub[/COLOR] MG14Sep51
[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] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To Columns.Count)
        [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, 2)
        ray(n, 1) = Dn: ray(n, 2) = Dn(, 2)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
        Q(1) = Q(1) + 1
        ray(Q(0), Q(1)) = Dn(, 2)
        oMax = Application.Max(oMax, Q(1))
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Range("C1").Resize(.Count, oMax) = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[powerman4912]

Works great, when trying it on a larger set of data though, I'm getting an 'Out of memory' error pointing to the line:

ReDim ray(1 To Rng.Count, 1 To Columns.Count)


Thanks!

 

[MickG]

I've just tried it on over 10K rows and 200 columns in Result, and it works OK.
How big is your data ???

 

[powerman4912]

Mick--thanks for your response.

Data columns A&B have about 5K rows, macro running for ~2500 rows

Thanks for your help.

 

[powerman4912]

Hi,

Wasn't clear in my original example...

when having this data, say in columns A & B:

A123 B123
A123 B124
A123 B125
A124 B126
A125 B127
A126 B128
A127 B129

...

in column C, i'd like to enter:

A123
A125
A127

run the macro in column D... and get back:

A123 B123 B124 B125
A125 B127
A127 B129

in columns C&D.

That is, I'd like the macro to return the values for only those that are entered in column C.

Sorry for the confusion. Thanks for any and all help.

 

[MickG]

Try this:-
Enter selected Data in InputBox seperated by a Comma.

[COLOR="Navy"]Sub[/COLOR] MG15Sep11
[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] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] StrgSel
 
 StrgSel = Application.InputBox(prompt:="Please Enter [COLOR="Navy"]Each[/COLOR] Selection seperated by a comma ", Title:="Select Data", Type:=2)
[COLOR="Navy"]If[/COLOR] StrgSel = vbNullString Or StrgSel = False [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
   ReDim ray(1 To Rng.Count, 1 To Columns.Count)
        [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] InStr(1, StrgSel, Dn.Value, TextCompare) > 0 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        n = n + 1
        .Add Dn.Value, Array(n, 2)
        ray(n, 1) = Dn: ray(n, 2) = Dn(, 2)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
        Q(1) = Q(1) + 1
        ray(Q(0), Q(1)) = Dn(, 2)
        oMax = Application.Max(oMax, Q(1))
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
oMax = IIf(oMax = 0, 2, oMax)
Range("C1").Resize(.Count, oMax) = ray
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[LittleBigAtlas]

Would someone be able to help with the Out of memory error?

Run-time error '7':

Out of memory

Debugger highlights: ReDim ray(1 To rng.Count, 1 To Columns.Count)

I'm using the first macro.

Thanks,