How to incorporate 2 sets of changing named ranges



Hi All
I'm a novice that needs help please..... sorry - I've tried but I'm stuck....
(one workbook, heaps of worksheets)

I've created a macro that runs a set of actions for multiple named ranges by
calling each (see code below)
It finds / copies / pastes data from different worksheets & named ranges
into an overview.

The macro adds a 1 or 2 or 3 to "collectionMT" and repeats the actions
against each named ranges:
CollectMT1, CollectMT2, CollectMT3, CollectMT4 etc through to CollectMT9

I don't know how to do the same (in the same macro) for the destination
named ranges?
Data is inserted into the second set of named ranges on the overview:
overviewMT1, overviewMT2, overviewMT3, overviewMT4 etc through to overviewMT9

They are numbered the same as the 1st set and they live together e.g.
collectionMT1 and overviewMT1 have to run in the same macro,
then collectionMT2 and overviewMT2 have to run together etc

I've marked the two times where the sub refer to the overviewMT1 (etc) named
ranges and needs to rotate through the numbers.
Thanks for your help in advance!

Sub MTcollection()

For i = 1 To 9
Call Test("collectionMT" & i)

Next i

End Sub

Sub Test(collectionMT As String)

Dim sh As Worksheet
Dim DestSh As Worksheet
Dim LastRowDest As Long
Dim NewRowDest As Long
Dim LastRowSource As Long
Dim DestLoc As Range
Dim MTRng As Range
Dim myrange As Range
Dim myRange1 As Range
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Collection").Visible = True
Set DestSh = ActiveWorkbook.Worksheets("Collection")
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Overview Template" And sh.Name <> "GRP Wkly Collection" And
sh.Name <> "GRP Qtrly Collection" And sh.Name <> DestSh.Name And sh.Visible =
True Then
Set MTRng = Nothing
On Error Resume Next
Set MTRng = sh.Range(collectionMT)
'' The above named range already changes to collectionMT2, collectionMT3,
collectionMT4 etc
On Error GoTo 0
If MTRng Is Nothing Then
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
LastRowDest = 1
Set DestLoc = DestSh.Range("A1")
LastRowDest = DestSh.Range("A" & Rows.Count).End(xlUp).Row
NewRowDest = LastRowDest + 1
Set DestLoc = DestSh.Range("A" & NewRowDest)
End If
LastRowSource = sh.Range("A" & Rows.Count).End(xlUp).Row
If LastRowSource + LastRowDest > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
Exit For
End If
With DestLoc
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Application.CutCopyMode = False
End If
End If

Sheets("Overview Template").Select
Application.Goto Reference:="OverviewMT1"
'''''''''''overviewMT1 will change to overviewMT2, overviewMT3, overviewMT4

Range("A1:BL" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.Sort Key1:=Range("G1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
With Selection
..HorizontalAlignment = xlLeft
End With
Range("A1:BL" & Cells(Rows.Count, "A").End(xlUp).Row).Select

Range(overviewMT1).Resize(1, 1).Offset(1, 0).Insert shift:=xlDown
'''''''''''''''overviewMT1 will change to overviewMT2, overviewMT3,
overviewMT4 etc

Sheets("Collection").Visible = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub


Thanks Mishell
That worked perfectly - so simply, but I didn't know you could do that.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question