Excel keeps shutting down using code

C

Crazyhorse

Why would excel keep shutting down after you run code. I do many copy and
paste from different spreadsheets.

Thanks

Here is the code

Sub TransferFormula()
Dim DeleteValue As String
Dim Rng As Range
Dim Calcmode As Long
Dim L As Long
Dim lastCellOfTab As String

On Error Resume Next

Application.DisplayAlerts = False

Worksheets("NewTemp").Delete
ActiveWorkbook.Unprotect Password:=MYPWD
UPWS ("Transactions")

With ThisWorkbook.Worksheets("Transactions").Activate
Range("A3").Select
Application.CutCopyMode = False
Selection.AutoFilter
WaitingX
Rows("2:2").Select

Selection.AutoFilter
WaitingX
Selection.AutoFilter Field:=3, Criteria1:="<=12/31/2007",
Operator:=xlAnd
WaitingX
Cells.SpecialCells(xlCellTypeLastCell).Activate
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).copy
End With


Sheets.Add.Name = "NewTemp"
ActiveSheet.Paste

With ThisWorkbook.Worksheets("Transactions").Activate
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).ClearContents

End With


With ThisWorkbook.Worksheets("Newtemp")
For rowCt = 1 To .UsedRange.Rows.Count
If Round(.Cells(rowCt, 6).Value, 2) <> 0 Then
deRow = 3
Do Until Trim(ThisWorkbook.Worksheets("Info").Cells(deRow,
255).Value) = _
(Trim(.Cells(rowCt, 1).Value) & " " & Trim(.Cells(rowCt,
9).Value)) _
Or Trim(ThisWorkbook.Worksheets("info").Cells(deRow,
255).Value) = ""
deRow = deRow + 1
Loop
ThisWorkbook.Worksheets("info").Cells(deRow, 255).Value = _
(Trim(.Cells(rowCt, 1).Value) & " " & Trim(.Cells(rowCt,
9).Value))

ThisWorkbook.Worksheets("info").Cells(deRow, 256).Value = _
ThisWorkbook.Worksheets("info").Cells(deRow, 256).Value + _
.Cells(rowCt, 6).Value
End If
Next rowCt
End With


With ThisWorkbook.Worksheets("Transactions").Activate
Selection.AutoFilter Field:=3
Range("A3").Select
ActiveWindow.FreezePanes = True
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate


End With

With ThisWorkbook.Worksheets("Info").Activate
Range("IU27").Select
ActiveCell.FormulaR1C1 = "=COUNTA(R[-24]C:R[-1]C)"

lastCellOfTab = ThisWorkbook.Worksheets("info").Cells(27, 255).Value
+ 2
Range("IT3").Select
ActiveCell.FormulaR1C1 = "=TRIM(MID(RC[1],4,31))"
Selection.AutoFill Destination:=Range("IT3:IT" & lastCellOfTab),
Type:=xlFillDefault
WaitingX
Range("IS3").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[2],3)"
Selection.AutoFill Destination:=Range("IS3:IS" & lastCellOfTab),
Type:=xlFillDefault
Range("IR3").Select
ActiveCell.FormulaR1C1 = "12/31/2007"
Range("IR4").Select
ActiveCell.FormulaR1C1 = "12/31/2007"
Range("IR3:IR4").Select
WaitingX
Selection.AutoFill Destination:=Range("IR3:IR" & lastCellOfTab),
Type:=xlFillDefault
Range("IS3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy

ThisWorkbook.Worksheets("Transactions").Activate
Range("A3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX
ThisWorkbook.Worksheets("info").Activate
Range("IT3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy

ThisWorkbook.Worksheets("Transactions").Activate
Range("I3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX

ThisWorkbook.Worksheets("info").Activate
Range("IV3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy


ThisWorkbook.Worksheets("Transactions").Activate
Range("F3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX
ThisWorkbook.Worksheets("info").Activate
Range("IR3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy

ThisWorkbook.Worksheets("Transactions").Activate
Range("C3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX
End With




ActiveWorkbook.Protect Password:=MYPWD
PWS ("Transactions")


MsgBox ("Transfer is complete. Have a good " & Format(Date, "DDDD") & ".")

End Sub

Sub Export_Sheet()
Dim NSA$, AppStr$, RelStr$
Dim B#
Dim Save_Path$, Save_File$
Application.ScreenUpdating = True
Save_Path = ThisWorkbook.Worksheets("Info").Cells(5, 1).Value &
ThisWorkbook.Worksheets("info").Cells(1, 1).Value & "\"
Do Until Right(Trim(Save_Path), 1) = "\"
Save_Path = Left(Save_Path, Len(Save_Path) - 1)
Loop
Save_Path = Left(Save_Path, Len(Save_Path) - 1)
If Right(Trim(Save_Path), 1) <> "\" Then
Save_Path = Save_Path & "\"
End If
Create_Directory (Save_Path)
Save_Path = Save_Path & "Archive\"
Create_Directory (Save_Path)
Save_File = "Cash_Sheet" & ThisWorkbook.Worksheets("info").Cells(1,
2).Value & "_" & Format(Now, "YYYYMMDD") & ".xls"
MenuBars(xlWorksheet).Reset
ActiveWorkbook.SaveCopyAs Save_Path & Save_File
Save_File

MsgBox ("Your Cash Sheet has been saved to " & Save_Path & Save_File)
workbook_activate2


Call TransferFormula ' this is the meat of the project.
End Sub
 
C

Crazyhorse

I figured it out.

I removed CALL

from

Call TransferFormula

Last line of code.



Crazyhorse said:
Why would excel keep shutting down after you run code. I do many copy and
paste from different spreadsheets.

Thanks

Here is the code

Sub TransferFormula()
Dim DeleteValue As String
Dim Rng As Range
Dim Calcmode As Long
Dim L As Long
Dim lastCellOfTab As String

On Error Resume Next

Application.DisplayAlerts = False

Worksheets("NewTemp").Delete
ActiveWorkbook.Unprotect Password:=MYPWD
UPWS ("Transactions")

With ThisWorkbook.Worksheets("Transactions").Activate
Range("A3").Select
Application.CutCopyMode = False
Selection.AutoFilter
WaitingX
Rows("2:2").Select

Selection.AutoFilter
WaitingX
Selection.AutoFilter Field:=3, Criteria1:="<=12/31/2007",
Operator:=xlAnd
WaitingX
Cells.SpecialCells(xlCellTypeLastCell).Activate
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).copy
End With


Sheets.Add.Name = "NewTemp"
ActiveSheet.Paste

With ThisWorkbook.Worksheets("Transactions").Activate
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).ClearContents

End With


With ThisWorkbook.Worksheets("Newtemp")
For rowCt = 1 To .UsedRange.Rows.Count
If Round(.Cells(rowCt, 6).Value, 2) <> 0 Then
deRow = 3
Do Until Trim(ThisWorkbook.Worksheets("Info").Cells(deRow,
255).Value) = _
(Trim(.Cells(rowCt, 1).Value) & " " & Trim(.Cells(rowCt,
9).Value)) _
Or Trim(ThisWorkbook.Worksheets("info").Cells(deRow,
255).Value) = ""
deRow = deRow + 1
Loop
ThisWorkbook.Worksheets("info").Cells(deRow, 255).Value = _
(Trim(.Cells(rowCt, 1).Value) & " " & Trim(.Cells(rowCt,
9).Value))

ThisWorkbook.Worksheets("info").Cells(deRow, 256).Value = _
ThisWorkbook.Worksheets("info").Cells(deRow, 256).Value + _
.Cells(rowCt, 6).Value
End If
Next rowCt
End With


With ThisWorkbook.Worksheets("Transactions").Activate
Selection.AutoFilter Field:=3
Range("A3").Select
ActiveWindow.FreezePanes = True
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate


End With

With ThisWorkbook.Worksheets("Info").Activate
Range("IU27").Select
ActiveCell.FormulaR1C1 = "=COUNTA(R[-24]C:R[-1]C)"

lastCellOfTab = ThisWorkbook.Worksheets("info").Cells(27, 255).Value
+ 2
Range("IT3").Select
ActiveCell.FormulaR1C1 = "=TRIM(MID(RC[1],4,31))"
Selection.AutoFill Destination:=Range("IT3:IT" & lastCellOfTab),
Type:=xlFillDefault
WaitingX
Range("IS3").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[2],3)"
Selection.AutoFill Destination:=Range("IS3:IS" & lastCellOfTab),
Type:=xlFillDefault
Range("IR3").Select
ActiveCell.FormulaR1C1 = "12/31/2007"
Range("IR4").Select
ActiveCell.FormulaR1C1 = "12/31/2007"
Range("IR3:IR4").Select
WaitingX
Selection.AutoFill Destination:=Range("IR3:IR" & lastCellOfTab),
Type:=xlFillDefault
Range("IS3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy

ThisWorkbook.Worksheets("Transactions").Activate
Range("A3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX
ThisWorkbook.Worksheets("info").Activate
Range("IT3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy

ThisWorkbook.Worksheets("Transactions").Activate
Range("I3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX

ThisWorkbook.Worksheets("info").Activate
Range("IV3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy


ThisWorkbook.Worksheets("Transactions").Activate
Range("F3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX
ThisWorkbook.Worksheets("info").Activate
Range("IR3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy

ThisWorkbook.Worksheets("Transactions").Activate
Range("C3").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Activate
Selection.PasteSpecial Paste:=xlPasteValues
WaitingX
End With




ActiveWorkbook.Protect Password:=MYPWD
PWS ("Transactions")


MsgBox ("Transfer is complete. Have a good " & Format(Date, "DDDD") & ".")

End Sub

Sub Export_Sheet()
Dim NSA$, AppStr$, RelStr$
Dim B#
Dim Save_Path$, Save_File$
Application.ScreenUpdating = True
Save_Path = ThisWorkbook.Worksheets("Info").Cells(5, 1).Value &
ThisWorkbook.Worksheets("info").Cells(1, 1).Value & "\"
Do Until Right(Trim(Save_Path), 1) = "\"
Save_Path = Left(Save_Path, Len(Save_Path) - 1)
Loop
Save_Path = Left(Save_Path, Len(Save_Path) - 1)
If Right(Trim(Save_Path), 1) <> "\" Then
Save_Path = Save_Path & "\"
End If
Create_Directory (Save_Path)
Save_Path = Save_Path & "Archive\"
Create_Directory (Save_Path)
Save_File = "Cash_Sheet" & ThisWorkbook.Worksheets("info").Cells(1,
2).Value & "_" & Format(Now, "YYYYMMDD") & ".xls"
MenuBars(xlWorksheet).Reset
ActiveWorkbook.SaveCopyAs Save_Path & Save_File
Save_File

MsgBox ("Your Cash Sheet has been saved to " & Save_Path & Save_File)
workbook_activate2


Call TransferFormula ' this is the meat of the project.
End Sub
Click to expand...
 
J

Jim Cone

You may find other things of interest if you...
Add: "Option Explicit" as the first line of your module.
Add: "On Error GoTo 0" immediately after "Worksheets("NewTemp").Delete"
--
Jim Cone
Portland, Oregon USA


"Crazyhorse"
wrote in message
I figured it out.
I removed CALL
from
Call TransferFormula
Last line of code.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Dynamic chart problem 1
change all specific row references to next row available in fill downformula 2
Run a procedure in all the sheets of the workbook. 1
VBA problem. 4
Something in this is causing a crash 2
Help again!!! 1
Macro to generate FileName of the source file 1
wrong code 1

Top