Concatenate based on values in another column

Steve1977

New Member
Joined
May 16, 2019
Messages
33
Hi all, first time post so I hope I'm following the correct procedure :)

Was really hoping someone could give me guidance. Basically I have a file as per the information below and I need to merge Column2 and Column3 - but based on the value in Column 1.

PARTNO1HyundaiAccent
PARTNO1Hyundaii30
PARTNO1Hyundaii40
PARTNO2HyundaiAccent
PARTNO2SubaruImpreza
PARTNO2ToyotaCelica
PARTNO3ToyotaCelica
PARTNO3ToyotaMR2

<tbody>
</tbody>

So in the past I've done a CONCATENATE formula for each PARTNO in Column 1, but I now have significantly more part numbers and it's way too time consuming to do them all in one.

Basically the finished file needs to look like this:

PARTNO1Hyundai Accent, i30, i40
PARTNO2Hyundai Accent, Subaru Impreza, Toyota Celica
PARTNO3Toyota Celica, MR2

<tbody>
</tbody>

What's important to mention with this is that if the Car Make in Column 2 is different, it then includes the next unique Car Make from Column 2 as long as it's associated with the PARTNO in Column A.

However, I also don't mind if it looks like this with the next unique car make on a second line.

PARTNO1Hyundai Accent, i30, i40
PARTNO2Hyundai Accent
PARTNO2Subaru Impreza
PARTNO2Toyota Celica
PARTNO3Toyota Celica, MR2

<tbody>
</tbody>


Hope this has been explained well and appreciate any feedback to guide me along the way :)
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Hi & welcome to MrExcel.
How about
Code:
Sub Steve1977()
   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
         If Not Dic(Cl.Value).Exists(Cl.Offset(, 1).Value) Then
            Dic(Cl.Value).Add (Cl.Offset(, 1).Value), Cl.Offset(, 2).Value
         Else
            Dic(Cl.Value)(Cl.Offset(, 1).Value) = Dic(Cl.Value)(Cl.Offset(, 1).Value) & ", " & Cl.Offset(, 2).Value
         End If
      Next Cl
   End With
   With Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")
      For Each Ky In Dic.Keys
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic(Ky).Count)
            .Value = Ky
            .Offset(, 1).Resize(, 2).Value = Application.Transpose(Array(Dic(Ky).Keys, Dic(Ky).Items))
         End With
      Next Ky
   End With
End Sub
Change sheet names in red to suit.
 
Upvote 0
That's really good of you to take the time to post that - thank you!

It's kinda working but it extracts it as the following:

PARTNO1Hyundaii30, i40
PARTNO2HyundaiAccent
PARTNO2SubaruImpreza
PARTNO2ToyotaCelica
PARTNO3ToyotaCelica, MR2
PARTNO1Hyundaii30, i40
PARTNO2HyundaiAccent
PARTNO2SubaruImpreza
PARTNO2ToyotaCelica
PARTNO3ToyotaCelica, MR2
PARTNO1Hyundaii30, i40
PARTNO2HyundaiAccent
PARTNO2SubaruImpreza
PARTNO2ToyotaCelica
PARTNO3ToyotaCelica, MR2

<colgroup><col width="80" span="3" style="width:48pt"> </colgroup><tbody>
</tbody>


So it's duplicated the data and removed 'Accent' from PARTNO1.
Pretty amazing to get this far though!
 
Upvote 0
STOP THE PRESS!!!!
I've put a header in and now it works! Absolutely brilliant!

PARTNO1HyundaiAccent, i30, i40
PARTNO2HyundaiAccent
PARTNO2SubaruImpreza
PARTNO2ToyotaCelica
PARTNO3ToyotaCelica, MR2


<colgroup><col><col span="2"></colgroup><tbody>
</tbody>


Are you able to explain how this works? Be nice to know the fundamentals to it all.
To take it one step further, how would I code in a concatenate? Basically merge Column B with Column C.

Also, where it recognises that Column B has a different value associated with the same part number (so it recognises that Hyundai, Subaru and Toyota need to be put on seperate lines). is there a way when doing the Concatenate so it lists it like this?

PARTNO1 Hyundai Accent, i30, i40 (no change on this)
PARTNO2 Hyundai Accent. Subaru Impreza. Toyota Celica (so the different vehicles where Column 2 is the same for the one part number, is seperated by a full stop?
 
Upvote 0
How about
Code:
Sub Steve1977()
   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant, K As Variant
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet1")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Dic.Exists(Cl.Value) Then Dic.Add Cl.Value, CreateObject("scripting.dictionary")
         If Not Dic(Cl.Value).Exists(Cl.Offset(, 1).Value) Then
            Dic(Cl.Value).Add (Cl.Offset(, 1).Value), Cl.Offset(, 2).Value
         Else
            Dic(Cl.Value)(Cl.Offset(, 1).Value) = Dic(Cl.Value)(Cl.Offset(, 1).Value) & ", " & Cl.Offset(, 2).Value
         End If
      Next Cl
   End With
   With Sheets("Sheet2")
      For Each Ky In Dic.Keys
         With .Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Value = Ky
            For Each K In Dic(Ky)
               .Offset(, 1).Value = .Offset(, 1).Value & ", " & K & ", " & Dic(Ky)(K)
            Next K
            .Offset(, 1).Value = Replace(.Offset(, 1).Value, ", ", "", 1, 1)
         End With
      Next Ky
   End With
End Sub
 
Upvote 0
This is absolutely amazing!

Whereby it seperates unique makes and it's respective model. At the moment it will state Hyundai Accent, Subaru, Impreza, Toyota, Celica

But could it state

Hyundai Accent. Subaru Impreza. Toyota Celica

So the comma's in between Column 2 and 3 has been removed. Then before a new vehicle it puts a full stop.
 
Upvote 0
To remove the comma's in between each model I've amended the line in the last bit to

.Offset(, 1).Value = .Offset(, 1).Value & ", " & K & " " & Dic(Ky)(K)
 
Upvote 0
Try
Code:
      For Each Ky In Dic.Keys
         With .Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Value = Ky
            For Each K In Dic(Ky)
               .Offset(, 1).Value = .Offset(, 1).Value & ". " & K & " " & Dic(Ky)(K)
            Next K
            .Offset(, 1).Value = Replace(.Offset(, 1).Value, ". ", "", 1, 1)
         End With
      Next Ky
 
Upvote 0
EDIT: Nice one!!! I've been looking through the various coding updates you've sent to try and get a grasp of this, but what can I say...absolutely unbelievable mate and I really value your help. What a great forum! :)
 
Last edited:
Upvote 0
Armed with applying the Macro I've ran into a peculiar issue. Basically with all the data I'm using, I need to get rid of Duplications in Column A and Column C.
I then need to get rid of extra information contained in Brackets in Column C.

To do this I simply created individual macro's for these two actions and added them to the beginning of the code (as per below), but when I run it, for some reason it does the following:

Has one space before a comma
Has two spaces before a comma
Has one space before a fullstop.

I did create 3 individual macro's to look for the instances above but it didn't seem to work.

I'll still do some trial and error with it to try and find but thought I'd ask here and maybe there's a better way to apply the code rather than simply copying and pasting individual macro's?

Code:
' Removes Duplicates    Columns("A:C").Select
    ActiveSheet.Range("$A$1:$C$1000000").RemoveDuplicates Columns:=Array(1, 3), _
        Header:=xlNo


' Removes Brackets
    Cells.Replace What:="(*)", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


Data I'm using:

100002AUDI100 (43, C2)
100002AUDI100 (43, C2)
100002AUDI100 (C1)
100002AUDI100 (C1)
100002AUDI100 (C1)
100002AUDI100 (C1)
100002AUDI100 (C1)
100002AUDI100 (C1)
100002AUDI100 Coupe (C1)
100002AUDI100 Coupe (C1)
100002AUDI50 (86)
100002AUDI50 (86)
100002AUDI50 (86)
100002AUDI50 (86)
100002AUDI50 (86)
100002AUDI60
100002AUDI75
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (80, 82, B1)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (81, 85, B2)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (89, 89Q, 8A, B3)
100002AUDI80 (8C2, B4)
100002AUDI80 (8C2, B4)
100002AUDI80 (8C2, B4)
100002AUDI80 (8C2, B4)
100002AUDI80 (8C2, B4)
100002AUDI80 (8C2, B4)
100002AUDI80 Avant (8C5, B4)
100002AUDI90 (81, 85, B2)
100002AUDI90 (81, 85, B2)
100002AUDI90 (81, 85, B2)
100002AUDI90 (81, 85, B2)
100002AUDI90 (81, 85, B2)
100002AUDI90 (89, 89Q, 8A, B3)
100002AUDI90 (89, 89Q, 8A, B3)
100002AUDI90 (89, 89Q, 8A, B3)
100002AUDI90 (89, 89Q, 8A, B3)

<colgroup><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0

Forum statistics

Threads
1,213,506
Messages
6,114,027
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top