Move Data in Columns to Rows

[jpfaff]

Greetings,

I have a Database that looks like this:

Item1 Component1
Item1 Component2
Item1 Component3
Item2 Component1
Item2 Component2
Item2 Component3
Item3 Component1
Item3 Componnet2
Item3 Component3
etc. etc. etc.

I want to manipulate the data to look like this:

Item1 Component1 Component2 Component3
Item2 Component1 Component2 Component3
Item3 Component1 Component2 Component3

How could I best achieve this?

 

[hiker95]

jpfaff,


I assume that your raw data is already sorted/grouped per your example, and resides in worksheet Sheet1.


Sample raw data in worksheet Sheet1:

Excel Workbook
	A	B
1	Item1	Component1
2	Item1	Component2
3	Item1	Component3
4	Item2	Component1
5	Item2	Component2
6	Item2	Component3
7	Item3	Component1
8	Item3	Component2
9	Item3	Component3
10
Sheet1

After the macro in a new worksheet Results (the macro will accomodate additional components):

Excel Workbook
	A	B	C	D
1	Item1	Component1	Component2	Component3
2	Item2	Component1	Component2	Component3
3	Item3	Component1	Component2	Component3
4
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
Option Base 1
Sub ReorgData()
' hiker95, 10/24/2011
' http://www.mrexcel.com/forum/showthread.php?t=587551
Dim w1 As Worksheet, wR As Worksheet
Dim A(), B(), O(), k
Dim r As Long, n As Long, c As Long, Amax As Long, s As Long, e As Long
Dim d1 As Object
Set w1 = Worksheets("Sheet1")
r = w1.Cells(Rows.Count, 1).End(xlUp).Row
A = w1.Range("A1:A" & r)
B = w1.Range("B1:B" & r)
Set d1 = CreateObject("scripting.dictionary")
For r = 1 To UBound(A)
  If Not d1.exists(A(r, 1)) Then
    d1(A(r, 1)) = d1.Count
  End If
Next r
k = d1.Keys
ReDim O(1 To d1.Count + 1, 1 To 1)
For r = 1 To d1.Count
  O(r, 1) = k(r - 1)
Next r
Amax = 1
ReDim Preserve O(1 To d1.Count + 1, 1 To Amax + 1)
For r = 1 To d1.Count
  s = Application.Match(O(r, 1), A, 0)
  e = Application.Match(O(r, 1), A, 1)
  If e - s + 1 > Amax Then
    Amax = e - s + 1
    ReDim Preserve O(1 To d1.Count + 1, 1 To Amax + 1)
  End If
  n = 1
  If s = e Then
    O(r, 2) = B(s, 1)
  Else
    For c = s To e Step 1
      n = n + 1
      O(r, n) = B(c, 1)
    Next c
  End If
Next r
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
wR.Range("A1").Resize(UBound(O), Amax + 1).Value = O
wR.UsedRange.Columns.AutoFit
wR.Activate
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgData macro.

 

[pboltonchina]

Try this on a copy of your data

Option Explicit

Sub Consolidate()
'JBeaucaire  (9/18/2009)
'Columnar data is Sorted/Matched by column A values, merge all other cells into row format
Dim LastRow As Long, NextCol As Long
Dim LastCol As Long, Rw As Long, Cnt As Long
Dim DelRNG As Range
Application.ScreenUpdating = False

'Sort data
    LastRow = Range("A" & Rows.count).End(xlUp).Row
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
    
'Seed the delete range
    Set DelRNG = Range("A" & LastRow + 10)
    
'Group matching names
    For Rw = LastRow To 2 Step -1
        If Cells(Rw, "A").Value = Cells(Rw - 1, "A").Value Then
            Range(Cells(Rw, "B"), Cells(Rw, Columns.count).End(xlToLeft)).Copy _
                Cells(Rw - 1, Columns.count).End(xlToLeft).Offset(0, 1)
            Set DelRNG = Union(DelRNG, Range("A" & Rw))
        End If
    Next Rw

'Delete unneeded rows all at once
    DelRNG.EntireRow.Delete (xlShiftUp)
    Set DelRNG = Nothing

'Add titles
    NextCol = Cells(1, Columns.count).End(xlToLeft).Column + 1
    LastCol = Cells(1, 1).CurrentRegion.Columns.count
    Range("B1", Cells(1, NextCol - 1)).Copy Range(Cells(1, NextCol), Cells(1, LastCol))

Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

[jpfaff]

Worked like a charm. Thank you so much.

 

[wirra]

Hi,

I want to do a similar process as jpfaff but when I use the code supplied by pboltonchina I don't get the correct result. My sample data is shown below - A1 to C9. After running the macro I get the data as shown in A13 to L15. As can be seen B and C work fine but A sort of repeats itself. I don't know much about VBA coding. Can someone please explain what is going wrong?

Also if column A is not sorted eg. A-C it also doesn't work properly. Does the code imply that that column A must be sorted?

Thanks for any help.

Bob

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	A	1	2	*	*	*	*	*	*	*	*	*
2	A	3	4	*	*	*	*	*	*	*	*	*
3	A	5	6	*	*	*	*	*	*	*	*	*
4	B	7	8	*	*	*	*	*	*	*	*	*
5	B	9	10	*	*	*	*	*	*	*	*	*
6	B	11	12	*	*	*	*	*	*	*	*	*
7	C	13	14	*	*	*	*	*	*	*	*	*
8	C	15	16	*	*	*	*	*	*	*	*	*
9	C	17	18	*	*	*	*	*	*	*	*	*
10	*	*	*	*	*	*	*	*	*	*	*	*
11	*	*	*	*	*	*	*	*	*	*	*	*
12	*	*	*	*	*	*	*	*	*	*	*	*
13	A	1	2	3	4	5	1	2	3	4	5	6
14	B	7	8	9	10	11	12	*	*	*	*	*
15	C	13	14	15	16	17	18	*	*	*	*	*
Sheet1 (5)

 

[hiker95]

wirra,


Sample raw data in the active worksheet, not sorted, in columns A, B, and C, before the macro:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	A	1	2
2	B	7	8
3	C	13	14
4	A	3	4
5	B	9	10
6	C	15	16
7	A	5	6
8	B	11	12
9	C	17	18
10
Sheet1 (5)

After the macro:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	A	1	2			A	1	2	3	4	5	6
2	B	7	8			B	7	8	9	10	11	12
3	C	13	14			C	13	14	15	16	17	18
4	A	3	4
5	B	9	10
6	C	15	16
7	A	5	6
8	B	11	12
9	C	17	18
10
Sheet1 (5)

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, 11/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=587551
Dim H(), lr As Long, r As Long, s As Long, e As Long, n As Long, c As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
H = Range("A1:C" & lr)
Range("A1:C" & lr).Sort Key1:=Range("A1"), Order1:=1, Key2:=Range("B1"), Order2:=1, Header:=xlNo
Rows(1).Insert
Range("A1") = "Title"
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(6), Unique:=True
Rows(1).Delete
lr = Cells(Rows.Count, 6).End(xlUp).Row
For r = 1 To lr Step 1
  s = Application.Match(Cells(r, 6), Columns(1), 0)
  e = Application.Match(Cells(r, 6), Columns(1), 1)
  If s = e Then
     c = Cells(r, Columns.Count).End(xlToLeft).Column + 1
     Cells(r, c).Resize(, 2).Value = Range("B" & s & ":C" & s).Value
  Else
    For n = s To e Step 1
      c = Cells(r, Columns.Count).End(xlToLeft).Column + 1
      Cells(r, c).Resize(, 2).Value = Range("B" & n & ":C" & n).Value
    Next n
  End If
Next r
Range("A1").Resize(UBound(H), 3).Value = H
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[wirra]

hiker95,

That works beautifully, thanks very much. Now if I can be a pain, what if I have 12 columns of data instead of 2 (eg. 12 months sales history) after the A, B, C etc. Can your code be easily changed so that is transposes the 12 columns to rows instead of the two in my sample?

Effectively what I have are product codes with 4 years of monthly sales history with each 12 months one under the other. Hope that makes sense.

Apologies, I should have given all the information in my original post.

Cheers,

Bob

 

[hiker95]

wirra,

You have hijacked jpfaff's thread. And, your new request is completely different.

I would suggest that you start your own New Post with an appropriate title.

And, in the New Post, have screenshots of the before and after raw data.

When this is accomplished you can send me a Private Message with a link to your New Post and I will be happy to assist.