B
BeSmart
Hi All
I have a macro that is working great - it creates an overview by searching
worksheets for data / coping & pasting values into an overview - but it only
does it for section of data.
I need to do the same actions (find and paste into specific sections of the
overview) for nine other sections...
Should I just create 9 macros and link the macros with "Call XXX"? Or is
there a way to do this automatically (via the one macro) so that I don't need
9 long ones?
Here are the steps that already happen in the macro:
First Run:
The macro clears all old data in all cells on the "collection" worksheet.
It then searches existing worksheets for a named range "GroupOne" and
copies/pastes the data found (as values & with formatting) into the
collection worksheet from A1.
The results are always within columns (A:BL) but the number of rows will vary.
Update Overview:
The macro then goes to the "overview template" worksheet and selects the
defined name range "OverviewfinalGroupOne" (variable range therefore named)
and clears all old content
Now it goes back to the collection worksheet to;
select all the "new" data (fixed columns (A:BL) but the number of rows will
vary)
sort the data - against column G in descending order
copy and insert the data into the "Overview template" starting at a specific
point....
Currently I've got it starting at cell "A44", but that cell will change
going forward - I need to insert copied cells into the cell that is in the
first column, 2nd row down within the named range I'm currently using e.g.
"OverviewfinalGroupOne". (Range A43:BL84 it select cell A44 & inserts copied
cells from there)
At this point, I need the macro to do all of the above again - but with the
following changes:
Named range GroupOne becomes GroupTwo
Named range OverviewfinalGroupOne becomes OverviewfinalGroupTwo
GroupOneRng becomes GroupTwoRng (or can this be "set" again for 2nd run and
the name re-used??)
I have to repeat the macro through to GroupNine / OverviewfinalGroupNine
Then I finish by deleting all unnecessary rows on the Overview Template
(i.e. delete the row if the cell in column A is blank).
Here is the current Code with named ranges for the First Run:
Sub CopyGroupSections()
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 GroupOneRng 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").Cells.Clear
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 GroupOneRng = Nothing
On Error Resume Next
Set GroupOneRng = sh.Range("GroupOne")
On Error GoTo 0
If GroupOneRng Is Nothing Then
Else
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
LastRowDest = 1
Set DestLoc = DestSh.Range("A1")
Else
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
GroupOneRng.Copy
With DestLoc
..PasteSpecial xlPasteValues
..PasteSpecial xlPasteFormats
End With
Application.CutCopyMode = False
End If
End If
Next
Sheets("Overview Template").Select
Application.Goto Reference:="overviewfinalGroupOne"
Selection.ClearContents
Sheets("Collection").Select
Range("A1").Select
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
Selection.Copy
Sheets("Overview Template").Select
Range("A44").Select
'''' Above range needs to change to select the cell in the 1st column and
2nd row within the
'''' named range (e.g. currently using "OverviewfinalGroupOne")
Selection.Insert Shift:=xlDown
'''''Repeat the above macro (to this point) for GroupTwo, GroupThree etc
through to GroupNine """""
''''Finish the macro with the following
Range("A41").Select
Set myRange = Sheets("Overview Template").Range("A41:A" & lastrow)
For Each c In myRange
If UCase(c.Value) = "" Then
If myRange1 Is Nothing Then
Set myRange1 = c.EntireRow
Else
Set myRange1 = Union(myRange1, c.EntireRow)
End If
End If
Next
If Not myRange1 Is Nothing Then
myRange1.Delete
Range("C17").Select
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Any help would be greatly appreciated.
I have a macro that is working great - it creates an overview by searching
worksheets for data / coping & pasting values into an overview - but it only
does it for section of data.
I need to do the same actions (find and paste into specific sections of the
overview) for nine other sections...
Should I just create 9 macros and link the macros with "Call XXX"? Or is
there a way to do this automatically (via the one macro) so that I don't need
9 long ones?
Here are the steps that already happen in the macro:
First Run:
The macro clears all old data in all cells on the "collection" worksheet.
It then searches existing worksheets for a named range "GroupOne" and
copies/pastes the data found (as values & with formatting) into the
collection worksheet from A1.
The results are always within columns (A:BL) but the number of rows will vary.
Update Overview:
The macro then goes to the "overview template" worksheet and selects the
defined name range "OverviewfinalGroupOne" (variable range therefore named)
and clears all old content
Now it goes back to the collection worksheet to;
select all the "new" data (fixed columns (A:BL) but the number of rows will
vary)
sort the data - against column G in descending order
copy and insert the data into the "Overview template" starting at a specific
point....
Currently I've got it starting at cell "A44", but that cell will change
going forward - I need to insert copied cells into the cell that is in the
first column, 2nd row down within the named range I'm currently using e.g.
"OverviewfinalGroupOne". (Range A43:BL84 it select cell A44 & inserts copied
cells from there)
At this point, I need the macro to do all of the above again - but with the
following changes:
Named range GroupOne becomes GroupTwo
Named range OverviewfinalGroupOne becomes OverviewfinalGroupTwo
GroupOneRng becomes GroupTwoRng (or can this be "set" again for 2nd run and
the name re-used??)
I have to repeat the macro through to GroupNine / OverviewfinalGroupNine
Then I finish by deleting all unnecessary rows on the Overview Template
(i.e. delete the row if the cell in column A is blank).
Here is the current Code with named ranges for the First Run:
Sub CopyGroupSections()
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 GroupOneRng 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").Cells.Clear
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 GroupOneRng = Nothing
On Error Resume Next
Set GroupOneRng = sh.Range("GroupOne")
On Error GoTo 0
If GroupOneRng Is Nothing Then
Else
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
LastRowDest = 1
Set DestLoc = DestSh.Range("A1")
Else
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
GroupOneRng.Copy
With DestLoc
..PasteSpecial xlPasteValues
..PasteSpecial xlPasteFormats
End With
Application.CutCopyMode = False
End If
End If
Next
Sheets("Overview Template").Select
Application.Goto Reference:="overviewfinalGroupOne"
Selection.ClearContents
Sheets("Collection").Select
Range("A1").Select
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
Selection.Copy
Sheets("Overview Template").Select
Range("A44").Select
'''' Above range needs to change to select the cell in the 1st column and
2nd row within the
'''' named range (e.g. currently using "OverviewfinalGroupOne")
Selection.Insert Shift:=xlDown
'''''Repeat the above macro (to this point) for GroupTwo, GroupThree etc
through to GroupNine """""
''''Finish the macro with the following
Range("A41").Select
Set myRange = Sheets("Overview Template").Range("A41:A" & lastrow)
For Each c In myRange
If UCase(c.Value) = "" Then
If myRange1 Is Nothing Then
Set myRange1 = c.EntireRow
Else
Set myRange1 = Union(myRange1, c.EntireRow)
End If
End If
Next
If Not myRange1 Is Nothing Then
myRange1.Delete
Range("C17").Select
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Any help would be greatly appreciated.