concatenating cells together depending on criteria?!

[ellison]

hi, is there a way to concatenate the contents of multiple cells together depending on IF certain criteria?

EG we have "item names" in Column A and their corresponding "order codes" in Column B

So sometimes we can have a plug, but it has 3 different order codes.

Is there a Marco or Function that could concatenate the info so that there is just one entry for plug (in row A) and 1 cell (in Row B ) which contains the 3 order codes (separated by a semicolon)

EG we have thousands of lines to go through, but in amongst them would be:
[TABLE="width: 141"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 141"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Row A[/TD]
[TD]Row B[/TD]
[/TR]
[TR]
[TD]plug[/TD]
[TD="align: left"]A45563[/TD]
[/TR]
[TR]
[TD]plug[/TD]
[TD]12223333[/TD]
[/TR]
[TR]
[TD]plug[/TD]
[TD]XYZ[/TD]
[/TR]
</tbody>[/TABLE]

We would really like all of that info on one single row =

[TABLE="width: 264"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Row A[/TD]
[TD]Row B[/TD]
[/TR]
[TR]
[TD]plug[/TD]
[TD="align: left"]A45563;12223333;XYZ

[/TD]
[/TR]
</tbody>[/TABLE]

 

[Fluff]

How about

Sub MyConcat()
   Dim Cl As Range
   Dim ary As Variant
   Dim i As Long
   
   ReDim ary(1 To Range("A" & Rows.Count).End(xlUp).Row, 1 To 2)
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            i = i + 1
            .Add Cl.Value, i
            ary(i, 1) = Cl.Value: ary(i, 2) = Cl.Offset(, 1).Value
         Else
            ary(.Item(Cl.Value), 2) = ary(.Item(Cl.Value), 2) & ";" & Cl.Offset(, 1).Value
         End If
      Next Cl
      Range("C2").Resize(.Count, 2).Value = ary
   End With
End Sub

 

[ellison]

That is absolutely BRILLIANT, many thanks indeed.

This is a process I like to refer to as "the list squash-down" and you have just made it immeasurably easier!!!!

Thanks again

Best

Neil

 

[Fluff]

Glad to help & thanks for the feedback

 

[Rick Rothstein]

That is absolutely BRILLIANT, many thanks indeed.

I know you have a solution, but I developed this little bit more compact macro before seeing that was the case, so I will post my macro (uses a completely different method) for your consideration.

[table="width: 500"]
[tr]
	[td]Sub ConcatLikeItems()
  Dim Ar As Range
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .Value = Evaluate("IF(" & .Address & "=" & .Offset(-1).Address & ",""""," & .Address & ")")
    For Each Ar In .SpecialCells(xlBlanks).Areas
      Ar(1).Offset(-1, 1) = Join(Application.Transpose(Ar(1).Offset(-1, 1).Resize(Ar.Count + 1)), ";")
    Next
    .SpecialCells(xlBlanks).EntireRow.Delete
  End With
End Sub[/td]
[/tr]
[/table]

Note: Unlike Fluff's code, my code physically replaces the original data with the compacted data. If you wanted to use my code but have the output go where Fluff's code goes, I can easily modify my code to do that.