Condensing multiple column's data into one row...

[egilliland]

Greetings!

I am using Excel to prepare a CSV file to upload to a website to indicate relationships between different items. The spreadsheet is presently formatted as follows:

A | B
-------
1 | 3
1 | 4
1 | 5
2 | 6
2 | 7
2 | 8

I need this so be formatted like this:

A | B | C | D
-----------------
1 | 3 | 4 | 5
2 | 6 | 7 | 8

I essentially need the second column's data condensed into one row per unique item in column one.

Thanks for your help!
Eric G.

 

[hiker95]

egilliland,


Welcome to the MrExcel forum.


Sample raw data in worksheet Sheet1:

Excel Workbook
	A	B
1	1	3
2	1	4
3	1	5
4	2	6
5	2	7
6	2	8
7
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D
1	1	3	4	5
2	2	6	7	8
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 ReorgData()
' hiker95, 07/18/2011
' http://www.mrexcel.com/forum/showthread.php?t=565180
Dim w1 As Worksheet, wR As Worksheet
Dim Area As Range, LR As Long, a As Long
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
wR.Activate
wR.Columns(1).Resize(, 2).Value = w1.Columns(1).Resize(, 2).Value
LR = Range("A" & Rows.Count).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
For a = LR To 2 Step -1
  If Range("A" & a).Value <> Range("A" & a - 1).Value Then Rows(a).Insert
Next a
Columns("A").Copy Destination:=Columns("C")
Columns("A").Delete
For Each Area In Columns("A").SpecialCells(xlCellTypeConstants).Areas
  Range("C" & Area.Row).Resize(, Area.Rows.Count).Value = Application.Transpose(Area)
Next Area
Columns("A").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("B1:B" & LR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[egilliland]

Thank you so much! This is exactly what I needed and it works like a charm!

Is there anywhere that I can pay you kudos or raise your reputation across this site for your assistance?

 

[hiker95]

egilliland,

You are very welcome.

Glad I could help.

Thanks for the feedback.

Come back anytime.