On Sunday, December 23, 2012 11:22:02 PM UTC-8, LearningHorse wrote:[color=blue][i]
Howard;1608209 Wrote:

On Sunday, December 23, 2012 12:59:11 AM UTC-8, LearningHorse

wrote:





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



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





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

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







--

LearningHorse

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