Solved: Concatenate into a Single Cell

[Blue_Bunny]

I have two columns A & B and I want to write to a blank column which is Col_C. Col_A contains Names and Col_B contains a String. I would like to concatenate all of the values contained in Col_B where the Names (From Col_A) are the same and place the output in a single cell on the first row of Col_C at each name change in Col_A.

I'm have trouble marrying the follwing two Subs in order to accomplish this task:

Sub 1

Sub ConcatNames()
Dim c As Range
For Each c In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Cells(1, 3) = Cells(1, 3) & " " & c
Next c
Cells(1, 3) = Trim(Cells(1, 3))
End Sub

Sub 2


Sub UniqueNames()
Dim i As Integer
Dim End_of_Row_A As Integer
Dim Temp As Variant

i = 2

End_of_Row_A = Range("A" & Rows.Count).End(xlUp).Row ' this finds the last used row in a column
For i = i To End_of_Row_A
Temp = Cells(i, 1).Value
If Cells(i - 1, 1).Value <> Temp Then

Cells(i, 3) = Temp

End If

Next i
End Sub


I thought of using Arrays, but have not given that a shot. Any help would be great!

[MikeO]

Sub Unique_Concat()
Dim TestCell As Range
Dim DataRange As Range
Dim NameArray() As String
Dim CodeArray() As String
Dim CodeString As String
Dim I As Integer
Dim MatchNum As Integer

Set DataRange = Range(ActiveSheet.Range("A2"), ActiveSheet.Range("A65536").End(xlUp))
ReDim NameArray(0)
ReDim CodeArray(0)
For Each TestCell In DataRange.Cells
MatchNum = -1
On Error Resume Next
MatchNum = Application.Match(TestCell, NameArray, 0)
On Error GoTo 0
If MatchNum >= 0 Then
CodeArray(MatchNum - 1) = CodeArray(MatchNum - 1) & TestCell.Offset(, 1)
Else
NameArray(UBound(NameArray)) = TestCell
CodeArray(UBound(CodeArray)) = TestCell.Offset(, 1)
ReDim Preserve NameArray(UBound(NameArray) + 1)
ReDim Preserve CodeArray(UBound(CodeArray) + 1)
End If
Next TestCell

For I = 0 To UBound(NameArray) - 1
DataRange.Resize(DataRange.Rows.Count + 1).Offset(-1).Find(NameArray(I)).Offset(, 2) = CodeArray(I)
Next I

End Sub

[RonMcK]

BB,

Here's another way to solve your problem:

Option Explicit

Sub ConcatStuff()

Dim Curr_Row As Long
Dim Name_Row As Long
Dim Name As String

Curr_Row = 2

Do While Cells(Curr_Row, 1) <> ""
Name_Row = Curr_Row
Cells(Name_Row, 3) = Cells(Curr_Row, 1)

Do While Cells(Curr_Row, 1) = Cells(Name_Row, 1) And Cells(Curr_Row, 1) <> ""
Cells(Name_Row, 3) = Cells(Name_Row, 3) & ", " & Cells(Curr_Row, 2)
Debug.Print Cells(Name_Row, 3)
Curr_Row = Curr_Row + 1
Loop

Loop

End Sub
The entries in Col C are comma-delimited.

Cheers!

[Blue_Bunny]

Thank you very much Mike! I failed to mention that I need commas so I inserted the commas in your solution here:


CodeArray(MatchNum - 1) = CodeArray(MatchNum - 1) & "," & TestCell.Offset(, 1)


this code is very impressive!

[Blue_Bunny]

Hello Ron,

Thank you as well !

I can actually follow your code, so now I will spend some time learning how to create solutions using both techniques.

[Simon Lloyd]

Blue Bunny, we are glad that VBAX and its members could help, if you have the solution you want please mark your thread Solved, this is done by using Thread Tools at the top of this page and use Mark Thread Solved then click Perform Action.