Concatenate IF criterias are met VBA

[Zenru]

Hello everybody, I have the need to concatenate multiple values if certain criterias are met.

I have a table that goes like this:

Color	Mat	Value	Val2
BLUE	X100	40	X
BLUE	D200	41	M
BLUE	X100	45	T
YELLOW	D200	30	S
YELLOW	HD2O	45	T
RED	X100	41	M
RED	X100	44	R

<tbody>
</tbody>

And I have another table I need to fill with the concatenated values in the other table:

Color	Mat	Value
BLUE	X100	40, 45
BLUE	D200	41
YELLOW	D200	30
YELLOW	HD2O	45
RED	X100	41, 44

<tbody>
</tbody>

If you notice, the UNIQUE value is COLOR&MAT. The values must be unique, not repeated. There might be instances where the COLOR&MAT will have repeated values, but they will be rare. So I need to modify this VBA code I found two be able to do this.

I don't know who wrote this code, and I am not sure if I can post the link to where I found it, but cheers to whoever wrote this!

TL;DR
The problem with this function is that it just accepts one criteria and it repeats all values. I need at least two criterias and for it to give back unique values only.

<code class="vb keyword">Function</code> <code class="vb plain">ConcatenateIf(CriteriaRange </code><code class="vb keyword">As</code> <code class="vb plain">Range, Condition </code><code class="vb keyword">As</code> <code class="vb keyword">Variant</code><code class="vb plain">, ConcatenateRange </code><code class="vb keyword">As</code> <code class="vb plain">Range, </code><code class="vb keyword">Optional</code> <code class="vb plain">Separator </code><code class="vb keyword">As</code> <code class="vb keyword">String</code> <code class="vb plain">= </code><code class="vb string">","</code><code class="vb plain">) </code><code class="vb keyword">As</code> <code class="vb keyword">Variant</code>

<code class="vb comments">'Update 20150414</code>

<code class="vb keyword">Dim</code> <code class="vb plain">xResult </code><code class="vb keyword">As</code> <code class="vb keyword">String</code>

<code class="vb keyword">On</code> <code class="vb keyword">Error</code> <code class="vb keyword">Resume</code> <code class="vb keyword">Next</code>
<code class="vb keyword">If</code> <code class="vb plain">CriteriaRange.Count <> ConcatenateRange.Count </code><code class="vb keyword">Then</code>
<code class="vb spaces">    </code><code class="vb plain">ConcatenateIf = CVErr(xlErrRef)</code>
<code class="vb spaces">    </code><code class="vb keyword">Exit</code> <code class="vb keyword">Function</code>
<code class="vb keyword">End</code> <code class="vb keyword">If</code>
<code class="vb keyword">For</code> <code class="vb plain">i = 1 </code><code class="vb keyword">To</code> <code class="vb plain">CriteriaRange.Count</code>
<code class="vb spaces">    </code><code class="vb keyword">If</code> <code class="vb plain">CriteriaRange.Cells(i).Value = Condition </code><code class="vb keyword">Then</code>
<code class="vb spaces">        </code><code class="vb plain">xResult = xResult & Separator & ConcatenateRange.Cells(i).Value</code>
<code class="vb spaces">    </code><code class="vb keyword">End</code> <code class="vb keyword">If</code>
<code class="vb keyword">Next</code> <code class="vb plain">i</code>
<code class="vb keyword">If</code> <code class="vb plain">xResult <> </code><code class="vb string">""</code> <code class="vb keyword">Then</code>
<code class="vb spaces">    </code><code class="vb plain">xResult = VBA.Mid(xResult, VBA.Len(Separator) + 1)</code>
<code class="vb keyword">End</code> <code class="vb keyword">If</code>
<code class="vb plain">ConcatenateIf = xResult</code>
<code class="vb keyword">Exit</code> <code class="vb keyword">Function</code>

<code class="vb keyword">End</code> <code class="vb keyword">Function</code>

Plus
I am not sure how hard will it be to do this, but if there is a way to concatenate an additional value in another column (VAL2) like this:

Color	Mat	Value
BLUE	X100	40 - X, 45 - T
BLUE	D200	41 - M
YELLOW	D200	30 - S
YELLOW	HD2O	45 - T
RED	X100	41 - M, 44

<tbody>
</tbody>

I will GREATLY satisfied with my original request, but if someone can help me with the plus in one go I will very much appreciate it.

 

[MickG]

Try this for results on sheet2 starting "A1"

[COLOR="Navy"]Sub[/COLOR] MG30Oct42
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Txt = Dn.Value & "," & Dn.Offset(, 1).Value
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
            .Add Txt, Dn.Offset(, 2).Value & "-" & Dn.Offset(, 3).Value
        [COLOR="Navy"]Else[/COLOR]
            .Item(Txt) = .Item(Txt) & ", " & Dn.Offset(, 2).Value & "-" & Dn.Offset(, 3).Value
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To .Count + 1, 1 To 3)
Ray(1, 1) = "Color"
Ray(1, 2) = "Mat"
Ray(1, 3) = "Value"
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    Ray(c, 1) = Split(K, ",")(0)
    Ray(c, 2) = Split(K, ",")(1)
    Ray(c, 3) = .Item(K)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Nani520]

Thanks, it works perfectly!!!