Converting multiple rows to single row based on a key

[p51mustang]

Hi:

I have an excel file in the format listed below that I would like convert to the new format. Was wondering if anybody had a elegant solution to the problem?

Input File:

a 1
a 2
a 3
b 1
b 3
c 2
c 4
c 6



Output File:

a 1 2 3
b 1 3
c 2 4 6


Thank you very much for your help.

P51

 

[Desu Nota from Columbus]

http://www.mrexcel.com/forum/showthread.php?p=2728011&posted=1#post2728011

Take a look here I think this is exactly what you need.

 

[hiker95]

p51mustang,


Sample raw data before the macro:

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

After the macro:

Excel Workbook
	A	B	C	D	E	F	G	H
1	a	1			a	1	2	3
2	a	2			b	1	3
3	a	3			c	2	4	6
4	b	1
5	b	3
6	c	2
7	c	4
8	c	6
9
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, 07/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=562081
Dim LR As Long, a As Long, SR As Long, ER As Long
Application.ScreenUpdating = False
Rows(1).Insert
Range("A1") = "TitleA"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:B" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
  , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
  False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(5), Unique:=True
LR = Range("E" & Rows.Count).End(xlUp).Row
For a = 2 To LR Step 1
  SR = Application.Match(Range("E" & a), Columns(1), 0)
  ER = Application.Match(Range("E" & a), Columns(1), 1)
  If SR = ER Then
    Range("F" & a) = Range("B" & SR)
  Else
    Range("F" & a).Resize(, ER - SR + 1).Value = Application.Transpose(Range("B" & SR & ":B" & ER).Value)
  End If
Next a
Rows(1).Delete
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[p51mustang]

Thank you guys for the elaborate solution. That was extremely helpful!

P51