Convert column data to single row separated by comma

[JaimeSing]

I have a set of data.
A B
1 a
1 b
1 c
1 d
2 b
2 c
2 d
3 a
3 d

I would like them to become like the following
A B
1 a,b,c,d
2 b,c,d
3 a,d

Is there any formulae that enable that? Or what VBA code which enable me to get the results? Please help me out. Thanks in advance!

 

[VoG]

Try

Sub Myjoin()
Dim Area As Range, LR As Long, i As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
    If Range("A" & i).Value <> Range("A" & i - 1).Value Then Rows(i).Insert
Next i
Columns("A").Copy Destination:=Range("E1")
Columns("A").Delete
For Each Area In Columns("A").SpecialCells(xlCellTypeConstants).Areas
    Area(1).Offset(, 1).Value = Join(Application.Transpose(Area), ", ")
Next Area
Columns("D").Copy Destination:=Range("A1")
Columns("D").Delete
Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

 

[MickG]

Try :-
Results in Column "C & D"

Dim Rng As Range, Dn As Range
Dim c
c = 1
Set Rng = Range(Range("A1"), Range("A" & rows.Count).End(xlUp))
    For Each Dn In Rng
        If Dn = Dn.Offset(1) Then
            Cells(c, 3) = Dn: Cells(c, 4) = Cells(c, 4) & Dn.Offset(, 1) & ", "
        Else
            Cells(c, 3) = Dn: Cells(c, 4) = Cells(c, 4) & Dn.Offset(, 1)
            c = c + 1
        End If
    Next Dn
End Sub

 

[snoopyhr]

if interested in formula , try this :

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P
1
2	Identifier	Your data		# of occ.	Unique Id	Extracted / Converted from vert. to Horz.
3	1	a		4	1	a	b	c	d
4	1	b		3	2	a	b	c
5	1	c		2	3	a	b
6	1	d
7	2	a
8	2	b
9	2	c
10	3	a
11	3	b
Sheet4

 

[hiker95]

JaimeSing,

Welcome to the MrExcel forum.


Sample data before the macro:

Excel Workbook
	A	B	C	D	E
1	1	a
2	1	b
3	1	c
4	1	d
5	2	b
6	2	c
7	2	d
8	3	a
9	3	d
10
Sheet1

After the macro:

Excel Workbook
	A	B	C	D	E
1	1	a		1	a,b,c,d
2	1	b		2	b,c,d
3	1	c		3	a,d
4	1	d
5	2	b
6	2	c
7	2	d
8	3	a
9	3	d
10
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 04/03/2011
' http://www.mrexcel.com/forum/showthread.php?t=540814
Dim LR As Long, a As Long, aa As Long, SR As Long, ER As Long, H As String
Application.ScreenUpdating = False
Columns("D:E").ClearContents
LR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:B" & LR).Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
  , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
  False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Rows(1).Insert
Range("A1") = "Test"
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(4), Unique:=True
Rows(1).Delete
LR = Cells(Rows.Count, 4).End(xlUp).Row
For a = 1 To LR Step 1
  SR = Application.Match(Cells(a, 4), Columns(1), 0)
  ER = Application.Match(Cells(a, 4), Columns(1), 1)
  H = ""
  For aa = SR To ER Step 1
    H = H & Cells(aa, 2) & ","
  Next aa
  If Right(H, 1) = "," Then H = Left(H, Len(H) - 1)
  Cells(a, 5) = H
Next a
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[snoopyhr]

Sorry I miss read your requirement, ignore the solution.

 

[JaimeSing]

Hi VoG,MikeG and hiker95, thanks for the code. it works!

hiker95, how would the codes change if i need the results to be on a new worksheet in the file, to choose the column that i want to be comma separated? for instance, choosing column C to be comma separated.

A B C
1 Chance a
1 Chance b
1 Chance c
2 Position a
2 Position b
2 Position d

to become (on a new worksheet)

A B C
1 Chance a,b,c
2 Position a,b,d


snoopyhr! thanks for replying to the thread too

 

[hiker95]

JaimeSing,


Sample raw data in worksheet Sheet1:

Excel Workbook
	A	B	C
1	1	Chance	a
2	1	Chance	b
3	1	Chance	c
4	2	Position	a
5	2	Position	b
6	2	Position	c
7
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C
1	1	Chance	a,b,c
2	2	Position	a,b,c
3
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgDataV2()
' hiker95, 04/03/2011
' http://www.mrexcel.com/forum/showthread.php?t=540814
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, a As Long, aa As Long, SR As Long, ER As Long, H As String
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
Set wR = Worksheets("Results")
LR = w1.Cells(Rows.Count, 1).End(xlUp).Row
w1.Range("A1:C" & LR).Sort Key1:=w1.Range("A1"), Order1:=xlAscending, Key2:=w1.Range("B1") _
  , Order2:=xlAscending, Key3:=w1.Range("C1"), Order3:=xlAscending, Header:= _
  xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
w1.Rows(1).Insert
w1.Range("A1:B1") = [{"A","B"}]
w1.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns("A:B"), Unique:=True
w1.Rows(1).Delete
wR.Rows(1).Delete
LR = wR.Cells(Rows.Count, 1).End(xlUp).Row
For a = 1 To LR Step 1
  SR = Application.Match(wR.Cells(a, 1), w1.Columns(1), 0)
  ER = Application.Match(wR.Cells(a, 1), w1.Columns(1), 1)
  H = ""
  For aa = SR To ER Step 1
    H = H & w1.Cells(aa, 3) & ","
  Next aa
  If Right(H, 1) = "," Then H = Left(H, Len(H) - 1)
  wR.Cells(a, 3) = H
Next a
Application.ScreenUpdating = True
End Sub

Then run the ReorgDataV2 macro.