Originally Posted by Howard

On Sunday, December 23, 2012 12:59:11 AM UTC-8, LearningHorse wrote:[color=blue][i]


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 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 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 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
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

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

Originally Posted by 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