Create Indexed Table for Color Variations w/ Formulae

[DougStroud]

I have two rows of data, Col. D is an index color, Col. E is the variations of this index color value. I would like a formulae solution to find all the variations for the index value and transpose this value across the columns.

The table below is just a small sample. I have over 500 different color variations.

Book1
	D	E	F	G	H	I	J	K	L
1	Index	Variation		Index	Variation	Variation	Variation	Variation
2	Black+	Black/Black/Black		Assorted
3	Black+	Black/Black/Red/Silver		Black
4	Black+	Black/Black/Silver/Red		Black/Print
5	Black+	Black/Black/White		Black/Wash
6	Blue+	Blue/Black		Black+	Black/Black/Red/Silver	Black/Black/Silver/Red	Black/Black/White
7	Blue+	Blue/Black/White		Blue
8	Blue+	Blue/Blue		Blue+	Blue/Black	Blue/Black/White	Blue/Blue	Blue/Brown	Blue/Gloss
9	Blue+	Blue/Brown		Bronze+
10	Blue+	Blue/Gloss		Brown
11	Brown	Matte/Brown		Brown+	BearRug/Grid	BearRug/Stripes	Brown/Beige	Brown/Camo
12	Brown+	BearRug/Grid
13	Brown+	BearRug/Stripes
14	Brown+	Brown/Beige
15	Brown+	Brown/Camo
Sheet2

 

[NateO]

Hi Doug,

I don't think you're going to be able to pull this off with a user-friendly Worksheet Function construct, to any extent. I think it would require an array-entered UDF, and a messy one at that... I don't know, I guess we'll see...

In the interim, here's a VBA routine that will return all of Column E's matches based on Column D, and it will spread that across columns:

Private Sub arrLookUp( _
    ByRef rngIn As Range, _
    ByRef nameIn As String, _
    ByRef arrRet As Variant)
Dim tmpArr() As Variant, newArr() As String
Dim i As Long, j As Long
Let tmpArr = rngIn.Value
ReDim newArr(1 To UBound(tmpArr, 1))
For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    If tmpArr(i, 1) = nameIn Then
        Let j = j + 1
        Let newArr(j) = tmpArr(i, 2)
    End If
Next
If Not CBool(j) Then Exit Sub
ReDim Preserve newArr(1 To j)
Let arrRet = newArr
End Sub

Public Sub foobar()
Dim rngIn As Range
Dim arrRet As Variant
Const strSearch As String = "Black+"
Set rngIn = Range("D1:E16")
Call arrLookUp(rngIn, strSearch, arrRet)
If Not IsEmpty(arrRet) Then _
    Let ActiveCell.Resize(, UBound(arrRet)).Value = arrRet
End Sub

As written, you'd select the ActiveCell and run foobar(), and it should populate across. You can obviously tailor this, but perhaps it's a start.

Edit: Deleted an unecessary variable.

 

[DougStroud]

Thanks- Nate....
I will give it a go.... and post back

 

[DougStroud]

Thanks Nate,
To make this work.... could I ask you to put a loop in the right place that will look at the values heading down col. F?

I have 91 different index colors. Black+ goes from col. G:CR.
So rather than replace all the values in the line

Const strSearch As String = "Black+"

a loop would be nice to look down column F. Col. F is a unique filtered list now.
(Sorry for poaching here and hopefully not imposing too much).

 

[NateO]

Hi Doug,

The fact that you know what the adjustment needs to be done surprises me, in that you don't seem willing to experiment with making the adjustment yourself? Why not try to write the loop?

I'm not trying to be jerk, but try it, you might be pleasantly surprised! Hint, put the Loop in Foobar and pass the Range's Value as 'strSearch' in my original attempt.

 

[NateO]

It occurred to me that I should point out that I'm using a temporary Static Variable, 'arrRet', that will need to be dealt with in a Loop, should there be no matches... Possibly kind of subtle and potentially frustrating...

So, try the following:

Private Sub arrLookUp( _
    ByRef rngIn As Range, _
    ByRef nameIn As Variant, _
    ByRef arrRet As Variant)
Dim tmpArr() As Variant, newArr() As String
Dim i As Long, j As Long
Let tmpArr = rngIn.Value
ReDim newArr(1 To UBound(tmpArr, 1))
For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    If tmpArr(i, 1) = nameIn Then
        Let j = j + 1
        Let newArr(j) = tmpArr(i, 2)
    End If
Next
If CBool(j) Then
    ReDim Preserve newArr(1 To j)
    Let arrRet = newArr
    Else: Let arrRet = Empty
End If
End Sub

Public Sub foobar()
Dim rngIn As Range, arrLoopList() As Variant
Dim arrRet As Variant, i As Long
Set rngIn = Range("D1:E16")
Let arrLoopList = Range("F1:F5").Value
Application.ScreenUpdating = False
For i = LBound(arrLoopList, 1) To UBound(arrLoopList, 1)
    Call arrLookUp(rngIn, arrLoopList(i, 1), arrRet)
    If Not IsEmpty(arrRet) Then _
        Let Cells(i, 7).Resize(, UBound(arrRet)).Value = arrRet
Next
Application.ScreenUpdating = True
End Sub

Change D1:E16 to your entire Lookup array, and F1:F5 to your Unique list to Loop through. This cycles through Column F and populates Column G->to the Right with matches.

Hope this helps.

 

[DougStroud]

Nate,
I know.... I felt awkard asking.....
It is not the work, normally I am more than motivated to take it on. The main reason I asked was I have a long night of work ahead of me still-- and I was throwing myself on the mercy of the board tonight

I do not think you being anything near a jerk- I would have said the same thing..... I am super stoked to get such a slick solution- I am still trying to work through how all the code works. I am still at the beginning stages and just beginning to see how values are passed through references/arguments..

Anyway I will take another look at it-

Thanks for the help Nate,

Doug

 

[NateO]

You are welcome.

As I mentioned in my last post, I realized that it's not just a matter of adding a Loop, there were a few required tweaks, both being subtle. So, please see my revised code.

Speaking of big nights, I believe I'm off to create one! :wink:

 

[DougStroud]

Nate-
Already installed, ran and worked perfectly, Thanks!
You just saved me hours of work tonight- have two on me and put it on my account....
Here are the two changes I made to accomodate.
The nice thing about the first and second is I can study the differences between the two.
I will hit you up later, if that is ok, to go over them when I get this under my belt better.

Public Sub foobar()
Dim rngIn As Range, arrLoopList() As Variant
Dim arrRet As Variant, i As Long
Set rngIn = Range("D1:E600")
Let arrLoopList = Range("F1:F91").Value
Application.ScreenUpdating = False
For i = LBound(arrLoopList, 1) To UBound(arrLoopList, 1)
    Call arrLookUp(rngIn, arrLoopList(i, 1), arrRet)
    If Not IsEmpty(arrRet) Then _
        Let Cells(i, 7).Resize(, UBound(arrRet)).Value = arrRet
Next
Application.ScreenUpdating = True
End Sub

Cheers