Excel crashes after running macro

[ChrisA]

Hi,

I have a macro that has worked fine for years. A couple of months ago we were switched over to a new network and new profiles were created on all pc's. Since then the macro does not work at all on my PC. On other PC's it sometimes works and sometimes doesn't.

After I run the macro, I am unable to select cells, formulas do not calculate and one of the sheets flashes. As soon as I try any commands from the toolbar, I get the message "Excel has encountered a problem and needs to close."

I thought this problem might be similar to or related to this problem on the Microsoft website regarding manual calculation: http://support.microsoft.com/kb/331401. However, this is for Excel 2002 and I am using Excel 2003. In any case I installed SP3 for Office, but that did not resolve the problem. Thank you in advance for any insight you may have into this problem.

Here is the code:


Sub Update2()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim startdate As Date
Dim enddate As Date

startdate = InputBox("What is the starting date?")
enddate = InputBox("What is the ending date?")


With Application
.Calculation = xlManual
End With


Workbooks("Filecount").Sheets("daily").Range("a1:l" & Range("a65000").End(xlUp).Row).ClearContents
For p = 2 To Workbooks.Count
Workbooks(p).Activate


If ActiveWorkbook.Name <> "filecount.xls" And ActiveWorkbook.Name <> "Personal.xls" And Range("a2") <> "" Then
Range("a2:l" & Range("a2").End(xlDown).Row).Copy
Workbooks("Filecount").Sheets("Daily").Range("a65000").End(xlUp).Offset(1, 0).PasteSpecial

End If

Next p

Dim Wb As Workbook
For Each Wb In Application.Workbooks
If Wb.Name <> ThisWorkbook.Name And Wb.Name <> "PERSONAL.xls" Then Wb.Close False
Next Wb
Workbooks("Filecount").Sheets("Daily").Activate

Columns("a:a").Select
Selection.TextToColumns Destination:=Range("a1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(4, 1)), TrailingMinusNumbers:=True

Range("N2:N" & Range("a65000").End(xlUp).Row).FormulaR1C1 = _
"=IF(OR(LEFT(RC[-12],2)=""69"",LEFT(RC[-12],2)=""73"",ISNUMBER(MATCH(RC[-13],'By Team'!C[-3],0))),""KEEP"",""DELETE"")"

Range("a2:n" & Range("a65000").End(xlUp).Row).Sort Key1:=Range("N2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

deleterefs = Application.WorksheetFunction.CountIf(Range("n:n"), "DELETE")
If deleterefs > 0 Then
Range("n2:n" & deleterefs + 1).EntireRow.Delete
End If
Range("n:n").ClearContents



Range("a2:l" & Range("a65000").End(xlUp).Row).Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range( _
"k1"), Order2:=xlAscending, Key3:=Range("l1"), Order3:=xlAscending, _
Header:=xlNo

'Deletes duplicate files
For Each refnumber In Range("b2:b" & Range("a65000").End(xlUp).Row)
If refnumber.Value = refnumber.Offset(1, 0).Value And refnumber.Offset(0, 10).Value = refnumber.Offset(1, 10).Value Then
refnumber.EntireRow.ClearContents
End If
Next refnumber

Cells.Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlYes
Cells.Sort Key1:=Range("f2"), Order1:=xlAscending, Header:=xlYes

'deletes files that had a 3461 sent, but not during current period
For Each refnumber In Range("f2:f" & Range("a65000").End(xlUp).Row)
If refnumber.Value > enddate Or refnumber.Value < startdate And refnumber.Value <> "" Then
refnumber.EntireRow.ClearContents
End If
Next refnumber

Cells.Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlYes
Cells.Sort Key1:=Range("e2"), Order1:=xlAscending, Header:=xlYes

'If no 3461 was sent or printed and the 7501 was not transsmitted in the current period, the file will be deleted.
'If no 3461 was sent or printed and the 7501 was transmitted during the current period, the file will not be deleted.
'This should capture warehouse withdrawals.
For Each refnumber In Range("e2:e" & Range("a65000").End(xlUp).Row)
If refnumber.Offset(0, 1).Value = "" And refnumber.Offset(0, 2).Value = "" And ActiveCell.Value <> "" And (refnumber.Value > enddate Or refnumber.Value < startdate) Then
refnumber.EntireRow.ClearContents
End If
Next refnumber

Cells.Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlYes
Cells.Sort Key1:=Range("d2"), Order1:=xlAscending, Header:=xlYes

'Attempts to delete files that have been opened, but not transmitted. If a file
'1. Has no 7501 transmitted
'2. Has no 3461 transmitted
'3. Has no 3461 printed
'4. Is not an Inbond, or 06 entry or Section
'5. Has no entry type
'It will be deleted
For Each refnumber In Range("d2:d" & Range("a65000").End(xlUp).Row)
If refnumber.Offset(0, 1).Value = "" And refnumber.Offset(0, 2).Value = "" And refnumber.Offset(0, 3).Value = "" _
And refnumber.Offset(0, 5).Value = "" And refnumber.Offset(0, 6).Value <> "6" And refnumber.Offset(0, 6).Value <> "61" _
And refnumber.Offset(0, 6).Value <> "62" And refnumber.Offset(0, 6).Value <> "63" _
And Left(refnumber.Offset(0, -1).Value, 3) <> "SEC" And Left(refnumber.Offset(0, -1).Value, 8) <> "11300000" Or refnumber.Offset(0, 6).Value = "0" Then
refnumber.EntireRow.ClearContents
End If
Next refnumber

Cells.Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlYes

Range("c:j").ClearContents
Range("k:l").Copy
Range("c1").PasteSpecial
Range("k:l").ClearContents

On Error Resume Next
Range("c2:d" & Range("a65000").End(xlUp).Row).Replace What:="", Replacement:="=rand()*100", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False

Range("a2:d" & Range("a65000").End(xlUp).Row).Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlNo
Range("g2:g" & Range("a65000").End(xlUp).Row).FormulaR1C1 = "=IF(COUNTIF(R[-1]C[-5],RC[-5])=1,0,1)"
Range("h2:h" & Range("a65000").End(xlUp).Row).FormulaR1C1 = "=IF(COUNTIF(R[-1]C[-5],RC[-5])=1,0,1)"
Range("i2:i" & Range("a65000").End(xlUp).Row).FormulaR1C1 = "=COUNTA(RC[-5])"
Calculate

Cells.Copy
Cells.PasteSpecial Paste:=xlValues

Range("a2").Select
d = ActiveCell.Row

Range("a2").Select

Do Until ActiveCell = ""
myname = ActiveCell.Value
y = Application.WorksheetFunction.CountIf(Range("a2:a" & Range("a65000").End(xlUp).Row), myname)
Range("a" & y + ActiveCell.Row).EntireRow.Insert
Range("f" & y + ActiveCell.Row) = myname
Range("g" & y + ActiveCell.Row) = Application.WorksheetFunction.Sum(Range("g" & ActiveCell.Row & ":g" & y + ActiveCell.Row))
Range("h" & y + ActiveCell.Row) = Application.WorksheetFunction.Sum(Range("h" & ActiveCell.Row & ":h" & y + ActiveCell.Row))
Range("i" & y + ActiveCell.Row) = Application.WorksheetFunction.Sum(Range("i" & ActiveCell.Row & ":i" & y + ActiveCell.Row))
Range("a" & ActiveCell.Row & ":i" & y + ActiveCell.Row - 1).ClearContents
Range("a" & y + 1 + ActiveCell.Row).Select
Loop

Range("f2:i" & Range("f65000").End(xlUp).Row).Sort Key1:=Range("f2"), Order1:=xlAscending, Header:=xlNo
Range("f2:i" & Range("f65000").End(xlUp).Row).Copy
Range("a2").PasteSpecial
Range("f2:i" & Range("f65000").End(xlUp).Row).ClearContents
Range("b:d").NumberFormat = General


Range("a1") = "Employee Name"
Range("b1") = "# Of Entries"
Range("c1") = "# Of Invoices"
Range("d1") = "# Of Classifications"


Cells.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Range("a1").EntireRow.Insert
Sheets("By Team").Range("k1") = enddate
Range("a1") = enddate
Range("b1").FormulaR1C1 = "=MONTH(RC[-1])+3"
Range("c1").FormulaR1C1 = "=DAY(RC[-2])"

Range("B1:C1").Select
Selection.Font.ColorIndex = 2
Columns("B:D").Select
Selection.NumberFormat = "General"
Range("A2:D2").Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("A:D").Select
Columns("A:D").EntireColumn.AutoFit


With Application
.Calculation = xlAutomatic
End With

ActiveCell.Range("a65000").End(xlUp).Offset(2, 0).Select

With Selection
.HorizontalAlignment = xlRight
End With

StartR = 1
EndR = ActiveCell.Row - 1

ActiveCell.FormulaR1C1 = "Totals:"
ActiveCell.Range("b1:D1").Select

ActiveCell.FormulaR1C1 = "=SUM(R[" & StartR - EndR & "]C:R[-1]C)"

ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=SUM(R[" & StartR - EndR & "]C:R[-1]C)"

ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=SUM(R[" & StartR - EndR & "]C:R[-1]C)"

Range("a1").Select

Sheets("Weekly").Activate
ActiveSheet.Unprotect
Range("k1") = enddate
If Range("l1") = 2 Then
Range("a20000:i35000").ClearContents
End If

Sheets("daily").Activate
Set c = Range("b1")
Set d = Range("c1")
Range("A3:D3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("weekly").Activate


Range("a20000").Select
ActiveCell.Range("a45000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

Sheets(c).Activate
ActiveSheet.Unprotect
Range("a20000").Select
ActiveCell.Range("a45000").End(xlUp).Offset(1, 0).Select
Sheets("daily").Activate
Selection.Copy
Sheets(c).Activate
ActiveSheet.Paste


Range("f20000:f50000").Select

Selection.Consolidate Sources:= _
"R20000C1:R50000C4" _
, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
Range("k3").Select

ActiveSheet.Protect
Sheets("weekly").Activate
Range("f20000:f50000").Select

Selection.Consolidate Sources:= _
"R20000C1:R50000C4" _
, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
Range("K3").Select

If c = 4 Then
e = 15
Else: e = c - 1
End If

If d = 1 Or d = 2 Or d = 3 Then
Sheets(e).Activate
ActiveSheet.Unprotect
Range("k1").Select
Range("k1:n500").Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

ActiveSheet.Protect
End If


Application.CutCopyMode = False
Range("k3").Select

Sheets("BY TEAM").Activate

Range("A1").Select

ActiveWorkbook.Save

End Sub

 

[decklun]

When the code crashes, do you select debug? If so, which line of the code is it on?

If not, I suggest that you step thru your code by pushing F8 and watch what each line is doing and maybe you will find out which part of the code it gets stuck on.

One thing I noticed is that you set the display alerts and screen updating to false, and do not put them back to true at the end of your code. You do set the calculation to manual, and maybe when the macro crashes before you put it back to automatic is when you are unable to calculate formulas.

This might be a good time to try to clean up the code a bit by removing the code where you select a cell or range, and instead of referencing row 65000 .......

Range("N2:N" & Range("a65000").End(xlUp).Row).FormulaR1C1 =

try using rows.count so you will not a problem if you ever have more than 65000 rows....

Cells(Rows.Count, 1).End(xlup).Row

 

[ChrisA]

Hi,

I don't get a debug when I run the macro. The macro finishes running and only then is there a problem. I did step through and as I stepped through I would manually go to the toolbar to see if Excel would shut down. The point where this seems to occur is whenever the macro tries to change the number format. I wiped out the sections of the macro that do any number formatting and it seems to run OK. However, after the macro has run and I manually go to Excel to chagne the number format, I get the same message: "Excel has encountered a problem and needs to close..."

Why would number formatting cause this?

 

[decklun]

It could be a version problem - I don't think that the number format would cause the error. Since the macro was originally written in 2002, maybe you could copy and paste the macro into a new 2003 workbook then save it and try stepping thru it again...

 

[ChrisA]

OK I tried your suggestion and no luck. If anybody has any other ideas I would really appreciate it.