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 :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
30,427
Office Version
365
Platform
Windows
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.
 

Steve1977

New Member
Joined
May 16, 2019
Messages
33
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!
 

Steve1977

New Member
Joined
May 16, 2019
Messages
33
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?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
30,427
Office Version
365
Platform
Windows
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
 

Steve1977

New Member
Joined
May 16, 2019
Messages
33
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.
 

Steve1977

New Member
Joined
May 16, 2019
Messages
33
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)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
30,427
Office Version
365
Platform
Windows
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
 

Steve1977

New Member
Joined
May 16, 2019
Messages
33
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:

Steve1977

New Member
Joined
May 16, 2019
Messages
33
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>
 

Forum statistics

Threads
1,078,275
Messages
5,339,223
Members
399,286
Latest member
ossa

Some videos you may like

This Week's Hot Topics

Top