Line 34 isn't right, so how do you get the same print range as the sheet you
just copied?


Sub PrepareReport()

Dim wksLoc As Worksheet
Dim wksTemp As Worksheet
Dim wksNew As Worksheet
Dim wksRight As Worksheet
Dim deptCell As Range
Dim deptLoop As Range
Dim blankstr As Variant ' row number of extra blank stores


Set wksLoc = Sheets("Locations")
Set wksTemp = Sheets("Template")
Set wksRight = Sheets("Right")


'Select the list of depts
With wksLoc
Set deptLoop = .Range("c1", .Range("c1").End(xlDown))
End With


'Loop through each dept
For Each deptCell In deptLoop
With wksTemp
.Range("a5").Value = deptCell
dept = .Range("a5").Value
End With

'Create a new sheet for each dept
wksTemp.Copy Befo=wksRight
Set wksNew = ActiveSheet

Set ActiveSheet.PageSetup.PrintArea = wksTemp.PageSetup.PrintArea 'THIS
ISN'T RIGHT--HOW DO I GRAB THE PRINT RANGE FROM THE TEMPLATE SHEET?

With wksNew
'Name new worksheet to be dept:
.Name = Trim(dept)
'Replace formulas with values
.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Get rid of extra blank stores and set the print range
blankstr = Application.Match(0, .Range("a:a"), 0)

If IsError(blankstr) Then
Else
If blankstr 1 Then
'.Rows("1:" & blankstr - 1).Name = "'" & .Name & "'!Print_Area"
NOT USING THIS BECAUSE GRABS EXTRA COLS FOR MONTHS THAT ARE STILL NOT
COMPLETED
.Rows(blankstr & ":" & .Rows.Count).Delete
Else
End If
End If
End With


Next deptCell

End Sub



--
Thanks,
PTweety