Dim myRange As Range
Set myRange = Range("A4126,A4128,A4130")
If Not Intersect(ActiveCell, myRange) Is Nothing Then
ActiveCell.Copy Destination:=Range("B10")
ActiveCell.Copy Destination:=Range("B29")
End If

Just extend myRange for all your cells

--

HTH

RP
(remove nothere from the email address if mailing direct)


"JohnUK" wrote in message
...

Hi, I need some help with drastically shortening a macro
code.
I have in the region of 1000 named ranges that according
to a number in a certain cell the macro would pick up the
named ranges that correspond to it. I.e. If the active
cell = 4126 i need ranges A & B to be picked up and
pasted elsewhere. The code below would probably explain
further, but as you can imagine, it would end up being a
massively long code that would take me hours to write.

If ActiveCell = "4126" Then
Application.Goto Reference:="A_4126"
Selection.Copy
Sheets("Report I").Select
Range("B10").Select
ActiveSheet.Paste
Application.Goto Reference:="B_4126"
Selection.Copy
Sheets("Report I").Select
Range("B29").Select
ActiveSheet.Paste
Range("A1").Select
End If
If ActiveCell = "4128" Then
Application.Goto Reference:="A_4128"
Selection.Copy
Sheets("Report I").Select
Range("B10").Select
ActiveSheet.Paste
Application.Goto Reference:="B_4128"
Selection.Copy
Sheets("Report I").Select
Range("B29").Select
ActiveSheet.Paste
Range("A1").Select
End If

And so on, and so on

Thanking you very much in advance
JOhn