Transpose columns to rows in groups

[LearningHorse]

Hi

I have an excel sheet with data. I have simplified an example (attached
where the source layout is like a pivot table: Product id in column
and in the header row the months from column B to column Y (Aug 2010 t
July 2012). Then sales data in the table. How do I get this transpose
in groups so that months and data are grouped with the product id in
new excel sheet with product id in column A, months in column B an
sales in column C? I guess I need to use programming with some sort o
loops, but I am not skilled in the technique. I hope someone can give m
guidance?

Thank you

+-------------------------------------------------------------------
|Filename: Transpose.zip
|Download: http://www.excelbanter.com/attachment.php?attachmentid=714
+-------------------------------------------------------------------

 

[Howard]

Hi



I have an excel sheet with data. I have simplified an example (attached)

where the source layout is like a pivot table: Product id in column A

and in the header row the months from column B to column Y (Aug 2010 to

July 2012). Then sales data in the table. How do I get this transposed

in groups so that months and data are grouped with the product id in a

new excel sheet with product id in column A, months in column B and

sales in column C? I guess I need to use programming with some sort of

loops, but I am not skilled in the technique. I hope someone can give me

guidance?



Thank you!





+-------------------------------------------------------------------+

|Filename: Transpose.zip |

|Download: http://www.excelbanter.com/attachment.php?attachmentid=714|

+-------------------------------------------------------------------+

Hi LearningHorse,


Give this code a try with the following additions to your worksheet example..
Select A2:A6 and while selected click in the name box and name the range P_id.
Select cell A8, then on the ribbon > Data > Data Valadition > Data Valadation > Allow > check list > click in source window > enter =P_id > OK.

Now click cell A8 and see the arrow, click arrow and select a P_id number. Now run the Macro Sub P_id().

Just in case you need help installing the code, first copy all the code, right click on the sheet tab and select View Code. Paste the code in the large white space which is the vb editor. Now you have three ways to run the code:

1. While in the vb editor make sure the cursor is within the code, that is between "Sub P_id()" and "End Sub". Look up on the tool bar and find DeBugand just below the word DeBug see the small trianglular green arrow (points to the right). Mouse-over the arrow and see "Run Sub/User Form F5". Either click on the arrow or hit F5 and it will fire the macro.

2. Back on the worksheet, Alt + Tab or click on the left most icon in the tool bar which is a small Excel icon just above the word Project, you can assign the macro to a button. On the ribbon > Developer > Insert > Forms Controls > click the button icon - upper left most icon > and on the worksheetleft-click-and-hold while you drag down and right to the size button you want. Release and see the Assign Macro box, click on the (your sheet name)P_id then OK. Just click the button to run the macro.

3. Assign macro to a Short-cut key. Developer > Macros > Options > Ctrl + box > enter a letter > OK. Avoid reserved letters like c - Copy or v - Paste. Now Ctrl + "your letter" runs the macro.

Wherever you see Sheets("Sheet2"), change to Sheets("your sheet name").


Option Explicit

Sub P_id()
Dim i As Long
Dim c As Range
i = Range("A8")
Application.ScreenUpdating = False
For Each c In Range("P_id")
If c.Value = i Then
c.Offset(0, 1).Resize(1, 24).Copy
Sheets("Sheet2").Range("C1200").End(xlUp).Offset(1, 0) _
.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Range("A8").Offset(-7, 1).Resize(1, 24).Copy
Sheets("Sheet2").Range("B1200").End(xlUp).Offset(1, 0). _
PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Sheets("Sheet2").Range("A1200").End(xlUp).Offset(1, 0). _
Resize(24, 1).Value = i
End If
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

Good luck and post back if you get hung up.
Regards,
Howard

 

[Ben McClave]

LearningHorse,

Here's another take on the transpose macro. This one will not require any special setup to run. Simply paste the code below into a module in your workbook, select the range containing your data or alter the code to hard-code a range (for example, "A1:Y6") and run the macro. The end result should be a sorted list that looks very similar to the sample you provided beginning three rows below the selected data.

Ben

Sub TransposeAll()
Dim rTrans As Range
Dim i As Long
Dim j As Long
Dim x As Long
Dim sRows As String

Application.ScreenUpdating = False

Set rTrans = Selection 'Or specify the range

With rTrans
i = .Columns.Count
j = .Rows.Count
.Copy
.Range("A1").Offset(j + 3, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With

Set rTrans = rTrans.Range("A1").Offset(j + 3, 1)
Set rTrans = rTrans.Resize(i, 1)

For x = 1 To j
Select Case x
Case 1
rTrans.Range("A1").Clear
sRows = rTrans.Range("A1").Row & ":" & rTrans.Range("A1").Row
Case 2
rTrans.Offset(0, -1).Value = _
rTrans.Range("A1").Offset(0, 1).Value
rTrans.Range("A1").Offset(0, 1).Clear
rTrans.Range("A1").Offset(0, -1).Clear
Case Else
rTrans.Copy rTrans.Offset((x - 2) * i, 0)
rTrans.Offset((x - 2) * i, -1).Value = _
rTrans.Range("A1").Offset(0, x - 1).Value
rTrans.Offset((x - 2) * i, 1).Value = _
rTrans.Offset(0, x - 1).Value
sRows = sRows & ", " & rTrans.Offset((x - 2) * i, 0).Row & ":" & _
rTrans.Offset((x - 2) * i, 0).Row
End Select
Next x

Range(sRows).EntireRow.Delete
Set rTrans = rTrans.Offset(0, 2)
Set rTrans = rTrans.Resize(i, j - 2)
rTrans.Clear

Set rTrans = rTrans.Offset(0, -3).Resize((i * (j - 1)) - j + 1, 3)
SortMe ActiveSheet, rTrans
rTrans.Activate
Set rTrans = Nothing
Application.ScreenUpdating = True
End Sub
Sub SortMe(ws As Worksheet, rSort As Range)
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort.Columns(1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rSort.Columns(2) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rSort
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

 

[LearningHorse]

LearningHorse,

Here's another take on the transpose macro. This one will not requir
any special setup to run. Simply paste the code below into a module i
your workbook, select the range containing your data or alter the cod
to hard-code a range (for example, "A1:Y6") and run the macro. The en
result should be a sorted list that looks very similar to the sample yo
provided beginning three rows below the selected data.

Ben

Sub TransposeAll()
Dim rTrans As Range
Dim i As Long
Dim j As Long
Dim x As Long
Dim sRows As String

Application.ScreenUpdating = False

Set rTrans = Selection 'Or specify the range

With rTrans
i = .Columns.Count
j = .Rows.Count
.Copy
.Range("A1").Offset(j + 3, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With

Set rTrans = rTrans.Range("A1").Offset(j + 3, 1)
Set rTrans = rTrans.Resize(i, 1)

For x = 1 To j
Select Case x
Case 1
rTrans.Range("A1").Clear
sRows = rTrans.Range("A1").Row & ":" & rTrans.Range("A1").Row
Case 2
rTrans.Offset(0, -1).Value = _
rTrans.Range("A1").Offset(0, 1).Value
rTrans.Range("A1").Offset(0, 1).Clear
rTrans.Range("A1").Offset(0, -1).Clear
Case Else
rTrans.Copy rTrans.Offset((x - 2) * i, 0)
rTrans.Offset((x - 2) * i, -1).Value = _
rTrans.Range("A1").Offset(0, x - 1).Value
rTrans.Offset((x - 2) * i, 1).Value = _
rTrans.Offset(0, x - 1).Value
sRows = sRows & ", " & rTrans.Offset((x - 2) * i, 0).Row & ":"
_
rTrans.Offset((x - 2) * i, 0).Row
End Select
Next x

Range(sRows).EntireRow.Delete
Set rTrans = rTrans.Offset(0, 2)
Set rTrans = rTrans.Resize(i, j - 2)
rTrans.Clear

Set rTrans = rTrans.Offset(0, -3).Resize((i * (j - 1)) - j + 1, 3)
SortMe ActiveSheet, rTrans
rTrans.Activate
Set rTrans = Nothing
Application.ScreenUpdating = True
End Sub
Sub SortMe(ws As Worksheet, rSort As Range)
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort.Columns(1) _
, SortOn:=xlSortOnValues, Order:=xlAscending
DataOption:=xlSortNormal
.SortFields.Add Key:=rSort.Columns(2) _
, SortOn:=xlSortOnValues, Order:=xlAscending
DataOption:=xlSortNormal
.SetRange rSort
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Thank you Ben

Your code worked nice.
You saved me a lot of work.
I will try to learn from your code how these loops are working.
Have a nice christmas time.

Rgds L

+-------------------------------------------------------------------
+-------------------------------------------------------------------

 

[Howard]

Hi LearningHorse,
Give this code a try with the following additions to your worksheet

example..

Select A2:A6 and while selected click in the name box and name the range

P_id.

Select cell A8, then on the ribbon > Data > Data Valadition > Data

Valadation > Allow > check list > click in source window > enter =P_id >


Now click cell A8 and see the arrow, click arrow and select a P_id

number. Now run the Macro Sub P_id().

Just in case you need help installing the code, first copy all the code,

right click on the sheet tab and select View Code. Paste the code in

the large white space which is the vb editor. Now you have three ways

to run the code:

1. While in the vb editor make sure the cursor is within the code, that

is between "Sub P_id()" and "End Sub". Look up on the tool bar and find

DeBug and just below the word DeBug see the small trianglular green

arrow (points to the right). Mouse-over the arrow and see "Run Sub/User

Form F5". Either click on the arrow or hit F5 and it will fire the


2. Back on the worksheet, Alt + Tab or click on the left most icon in

the tool bar which is a small Excel icon just above the word Project,

you can assign the macro to a button. On the ribbon > Developer >

Insert > Forms Controls > click the button icon - upper left most icon >

and on the worksheet left-click-and-hold while you drag down and right

to the size button you want. Release and see the Assign Macro box,

click on the (your sheet name)P_id then OK. Just click the button to

run the macro.

3. Assign macro to a Short-cut key. Developer > Macros > Options > Ctrl

+ box > enter a letter > OK. Avoid reserved letters like c - Copy or v

- Paste. Now Ctrl + "your letter" runs the macro.

Wherever you see Sheets("Sheet2"), change to Sheets("your sheet name").


Option Explicit

Sub P_id()

Dim i As Long

Dim c As Range

i = Range("A8")

Application.ScreenUpdating = False

For Each c In Range("P_id")

If c.Value = i Then

c.Offset(0, 1).Resize(1, 24).Copy

Sheets("Sheet2").Range("C1200").End(xlUp).Offset(1, 0) _

.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=True

Range("A8").Offset(-7, 1).Resize(1, 24).Copy

Sheets("Sheet2").Range("B1200").End(xlUp).Offset(1, 0). _

PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=True

Sheets("Sheet2").Range("A1200").End(xlUp).Offset(1, 0). _

Resize(24, 1).Value = i

End If

Application.ScreenUpdating = True

Application.CutCopyMode = False

End Sub

Good luck and post back if you get hung up.

Howard

Hi Howard

Thank you for your reply.

Your proposal was definitely a possible way to solve the problem.

However, if I understand your code right, I have to change the P_id in

the dropdown list for each product. This could work quite well if I had

only two or even ten Products, but I have thousands.

Is it some way to shift the product (P_id) in the dropdownlist

automatically?



Rgds LH





+-------------------------------------------------------------------+

+-------------------------------------------------------------------+

Do away with the drop down list and try this.
In the code find this line

For Each c In Range("A2:A6")

and change the "A2:A6" to suit your sheet, "A2:A5000" for instance.

You can still use a named range if you wish by selecting A2:A5000 and name it P_id. Then uncomment this line 'For Each c In Range("P_id") and discard or comment out For Each c In Range("A2:A5000")


Option Explicit

Sub P_id()
Dim c As Variant
Application.ScreenUpdating = False
'For Each c In Range("P_id")
For Each c In Range("A2:A6")
c.Offset(0, 1).Resize(1, 24).Copy
Sheets("Ark2").Range("C1200").End(xlUp).Offset(1, 0). _
PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Range("A1").Offset(0, 1).Resize(1, 24).Copy
Sheets("Ark2").Range("B1200").End(xlUp).Offset(1, 0). _
PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Sheets("Ark2").Range("A1200").End(xlUp).Offset(1, 0). _
Resize(24, 1).Value = c
Sheets("Ark2").Activate
With Sheets("Ark2").Range("A1200").End(xlUp).Select
End With
Next
Sheets("Ark1").Activate
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

Let me know how it goes.
Howard