Is it crashing on any particular line? If possible, can you send us a dummy
excel you are working on?
--
Vikas Bhandari
---------------------------
(E-Mail Removed)
http://excelnoob.blogspot.com
"pickytweety" wrote:
> 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 Before:=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
>
>
>
Similar Threads
