I have an Excel file with VBA code that was running fine in version 2002.
When I switched to version 2007, it now gives me intermittent "Microsoft
Office Excel has encountered a problem and needs to close." My choices are
to Send Error Report or Don't Send. It also has a check box for recovering
the file. I posted this issue before and it was decided that perhaps the
file was corrupted, so I rebuilt the file in the new version from scratch.
No change in the problem...ouch! So I'm going to post this code again in
hopes somebody will have an idea about how to fix this.
--
Thanks,
PTweety

Sub RunReport()

Dim strLocation As String
Dim rngLoop As Range
Dim rngCell As Range
Dim wksTemp As Worksheet
Dim wksScroll As Worksheet
Dim wksNew As Worksheet
Dim wksDirBonus As Worksheet
Dim wksAstBonus As Worksheet
Dim rngfill As Range

'Turn Automatic Calculation off and screen updating off
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'set the Template and Scroll List worksheets as objects
Set wksTemp = Sheets("Template")
Set wksScroll = Sheets("scroll list")
Set wksDirBonus = Sheets("YTD dir bonus summary")
Set wksAstBonus = Sheets("YTD asst bonus summary")

'clear the old "YTD dir bonus summary" page
With wksDirBonus
.Range("a9", .Range("a9").End(xlDown)).EntireRow.ClearContents
.Rows("2:5").Ungroup
.Rows("8:8").Ungroup
.Outline.ShowLevels RowLevels:=2, ColumnLevels:=2
End With

'clear the old "YTD asst bonus summary" page
With wksAstBonus
.Range("a9", .Range("a9").End(xlDown)).EntireRow.ClearContents
.Rows("2:5").Ungroup
.Rows("8:8").Ungroup
.Outline.ShowLevels RowLevels:=2, ColumnLevels:=2
End With

'Select the list of stores (range) on "scroll list" sheet
With wksScroll
Set rngLoop = .Range("a1", .Range("a1").End(xlDown))
End With

'show outline levels on wksTemp
wksTemp.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1

'Loop through each cell in rngLoop
For Each rngCell In rngLoop
With wksTemp
..Range("B1").Value = rngCell
..Calculate
strLocation = .Range("B1").Value
End With

'Create new sheet for strLocation and name it
wksTemp.Copy Befo=wksTemp
Set wksNew = ActiveSheet

With wksNew
..Name = Trim(strLocation)


'Select cells and replace formulas with values
..Cells.Copy
..Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

End With

'fill in the next line of wksDirBonus
CopyToNext wksDirBonus

'fill in the next line of wksAstBonus
CopyToNext wksAstBonus
Next

wksDirBonus.Rows("2:5").Group
wksDirBonus.Rows("8:8").Group
wksAstBonus.Rows("2:5").Group
wksAstBonus.Rows("8:8").Group
wksDirBonus.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
wksAstBonus.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1

'Hide working sheets
Sheets("Template").Visible = False
Sheets("Instructions").Visible = False
Sheets("str list").Visible = False
Sheets("SOSP03").Visible = False
Sheets("SOSP03 YTD").Visible = False
Sheets("ident sales").Visible = False
Sheets("ident sales YTD").Visible = False
Sheets("not ident history").Visible = False
Sheets("SOSP04-Inv").Visible = False
Sheets("SOSP05-labor actuals").Visible = False
Sheets("SOSP05 YTD-labor actuals").Visible = False
Sheets("Gordy's labor bud").Visible = False
Sheets("Gordy's labor bud YTD").Visible = False
Sheets("Gary's bonus").Visible = False
Sheets("Hal's out of stock").Visible = False
Sheets("Cust 1st fr Mys Shop").Visible = False
Sheets("Sales Brackets").Visible = False
Sheets("Key Retailing").Visible = False
Sheets("John's Safety").Visible = False
Sheets("Thats Our Promise").Visible = False
Sheets("Assoc Tracker").Visible = False
Sheets("Controllable").Visible = False
Sheets("Ranking").Visible = False
Sheets("scroll list").Visible = False

'Turn Automatic Calculation back on and screen updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Sub CopyToNext(wks As Worksheet)

Dim rngfill As Range

'MsgBox wks.Name

With wks
.Outline.ShowLevels RowLevels:=2, ColumnLevels:=2
.Calculate
Set rngfill = Nothing
Set rngfill = .Range("A" & .Rows.Count).End(xlUp)
Set rngfill = rngfill.Offset(1, 0)

.Rows(5).Copy '.Rows("5:5").Copy

rngfill.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

rngfill.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
End With

End Sub