VBA Transpose Multiple Rows

[jardenp]

I'm not very familiar with looping, so can someone help me transpose multiple rows?

I need this:
[TABLE="class: grid, width: 400"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Prop1[/TD]
[TD]Prop2[/TD]
[TD]Prop3[/TD]
[TD]Prop4[/TD]
[/TR]
[TR]
[TD]Pauline[/TD]
[TD]Papaya[/TD]
[TD]Pear[/TD]
[TD]Peach[/TD]
[TD]Plum[/TD]
[/TR]
[TR]
[TD]Kael[/TD]
[TD]Koala[/TD]
[TD]Kiwi[/TD]
[TD]Kudu[/TD]
[TD]Kakapo[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

To become this:
[TABLE="class: grid, width: 400"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Description[/TD]
[TD]Item[/TD]
[/TR]
[TR]
[TD]Pauline[/TD]
[TD]Prop1[/TD]
[TD]Papaya[/TD]
[/TR]
[TR]
[TD]Pauline[/TD]
[TD]Prop2[/TD]
[TD]Pear[/TD]
[/TR]
[TR]
[TD]Pauline[/TD]
[TD]Prop3[/TD]
[TD]Peach[/TD]
[/TR]
[TR]
[TD]Pauline[/TD]
[TD]Prop4[/TD]
[TD]Plum[/TD]
[/TR]
[TR]
[TD]Kael[/TD]
[TD]Prop1[/TD]
[TD]Koala[/TD]
[/TR]
[TR]
[TD]Kael[/TD]
[TD]Prop2[/TD]
[TD]Kiwi[/TD]
[/TR]
[TR]
[TD]Kael[/TD]
[TD]Prop3[/TD]
[TD]Kudu[/TD]
[/TR]
[TR]
[TD]Kael[/TD]
[TD]Prop4[/TD]
[TD]Kakapo[/TD]
[/TR]
</tbody>[/TABLE]

This can be done on the same sheet, leaving the original. For instance maybe the first cell of the created table is in G1.

Any help would be appreciated!

Thanks,

Josh in IN

 

[sheetspread]

Forget what I just said, I'll post something that works if no one else does first.

 

[jardenp]

I will check that out. Thanks!

 

[sheetspread]

Definitely check it out (works great on numerical data) but you have text, so a VBA solution (or formulas) is needed instead.

 

[lrobbo314]

Try this. You will need to make adjustments to your sheet names more than likely.

Sub xPose()
Dim LR      As Long
Dim LC      As Long
Dim x       As Long
Dim y       As Long
Dim wsIn    As Worksheet
Dim wsOut   As Worksheet

Set wsIn = Sheets("Sheet1")
Set wsOut = Sheets("Sheet2")
LR = wsIn.Range("A" & Rows.Count).End(xlUp).Row
LC = wsIn.Range("XFD1").End(xlToLeft).Column

For x = 2 To LR
    For y = 2 To LC
        wsOut.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = wsIn.Cells(x, 1)
        wsOut.Range("B" & Rows.Count).End(xlUp).Offset(1).Value = wsIn.Cells(1, y)
        wsOut.Range("C" & Rows.Count).End(xlUp).Offset(1).Value = wsIn.Cells(x, y)
    Next y
Next x

End Sub

 

[sheetspread]

This works too:

Excel 2010
	A	B	C	D	E	F	G	H
1	Name	Prop1	Prop2	Prop3	Prop4	Prop5	Prop6	Prop7
2	Pauline	Papaya	Pear	Peach	Plum	Pink	Paris	Pan
3	Kael	Koala	Kiwi	Kudu	Kakapo	Kentucky	Katmandu	Kar
4	Blue	Black	Barley	Beige	Brown	Bolt	Brick	Bass
5	Teal	Turquoise	Tan	Tar	Telephone	Try	Tank	Tin
Sheet4 (4)

Sub transpdata()
Dim LR%, LC%, i%, x%
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
Cells(1, LC + 2).Resize(, 3).Value = Array("Name", "Description", "Item")
x = 0
For i = 2 To LR
Cells(i + x, LC + 2).Resize(LC - 1).Value = Cells(i, 1).Value
Cells(i + x, LC + 3).Resize(LC - 1).Value = Application.Transpose(Cells(1, 2).Resize(, LC - 1).Value)
Cells(i + x, LC + 4).Resize(LC - 1).Value = Application.Transpose(Cells(i, 2).Resize(, LC - 1).Value)
x = x + LC - 2
Next
End Sub

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L
1	Name	Prop1	Prop2	Prop3	Prop4	Prop5	Prop6	Prop7		Name	Description	Item
2	Pauline	Papaya	Pear	Peach	Plum	Pink	Paris	Pan		Pauline	Prop1	Papaya
3	Kael	Koala	Kiwi	Kudu	Kakapo	Kentucky	Katmandu	Kar		Pauline	Prop2	Pear
4	Blue	Black	Barley	Beige	Brown	Bolt	Brick	Bass		Pauline	Prop3	Peach
5	Teal	Turquoise	Tan	Tar	Telephone	Try	Tank	Tin		Pauline	Prop4	Plum
6										Pauline	Prop5	Pink
7										Pauline	Prop6	Paris
8										Pauline	Prop7	Pan
9										Kael	Prop1	Koala
10										Kael	Prop2	Kiwi
11										Kael	Prop3	Kudu
12										Kael	Prop4	Kakapo
13										Kael	Prop5	Kentucky
14										Kael	Prop6	Katmandu
15										Kael	Prop7	Kar
16										Blue	Prop1	Black
17										Blue	Prop2	Barley
18										Blue	Prop3	Beige
19										Blue	Prop4	Brown
20										Blue	Prop5	Bolt
21										Blue	Prop6	Brick
22										Blue	Prop7	Bass
23										Teal	Prop1	Turquoise
24										Teal	Prop2	Tan
25										Teal	Prop3	Tar
26										Teal	Prop4	Telephone
27										Teal	Prop5	Try
28										Teal	Prop6	Tank
29										Teal	Prop7	Tin
Sheet4 (4)

 

[jardenp]

Wow! lrobbo314 and sheetspread, thank you so much. I actually have one application where lrobbo314's two-sheet solution works best and another where sheetspread's variable scale solution does. The calendar says June, but it sure feels like Christmas! Thank you so much for such elegant solutions!

Josh in IN

 

[lrobbo314]

Cool! Glad that you got it all squared away. Thanks for the feedback.