Excel macro crashes after running for a few minutes - excel

My code runs for about 5min and the goes into recovery error/message. I have posted 3 Call macros but have 40 in the code.
During the macro the cells need to calculate and I tried a time delay to help but no good.
Private Sub Worksheet_calculate()
If Range("$be8").Value = 1 Then
Application.EnableEvents = True
Call Macro1
Application.EnableEvents = False
End If
If Range("$bf8").Value = 1 Then
Application.EnableEvents = True
Call Macro2
Application.EnableEvents = False
End If
If Range("$bg8").Value = 1 Then
Application.EnableEvents = True
Call Macro3
Application.EnableEvents = False
End If
Sub Macro1()
'
'
Macro1 Macro
'
'
Sheets("Calc. 1").Select
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Wait (Now + TimeValue("0:00:05"))
Rows("7:7").Select
Selection.Copy
Rows("11:11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B2").Select
Sheets("Calc.").Select
Range("A7:Q50002").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
Calculate
Range("AZ3").Select
Selection.Copy
Range("BA3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B1").Select
Workbooks.Add
DoEvents
End Sub
Sub Macro2()
'
' Macro2 Macro
'
'
Sheets("Calc. 1").Select
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Wait (Now + TimeValue("0:00:05"))
Rows("7:7").Select
Selection.Copy
Rows("11:11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B2").Select
Sheets("Calc.").Select
Range("A8:Q50002").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
Calculate
Range("AZ3").Select
Selection.Copy
Range("BA3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B1").Select
Workbooks.Add
DoEvents
End Sub
Sub Macro3()
'
' Macro3 Macro
'
'
Sheets("Calc. 1").Select
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Wait (Now + TimeValue("0:00:05"))
Rows("7:7").Select
Selection.Copy
Rows("11:11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B2").Select
Sheets("Calc.").Select
Range("A9:Q50002").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
Calculate
Range("AZ3").Select
Selection.Copy
Range("BA3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B1").Select
Workbooks.Add
DoEvents
End Sub

First, this is just a big pack of recorded macros, and therefore nearly unreadable, as hinted by Matt Webb in its excellent comment. That being said, I went to do some analysis.
The macros are strictly the same, besides the column of the Range("A7:Q50002").Select, which varies from 7 to 9 (and probably up to 46, if you really have 40 of those). Time to make a proper sub with a parameter :
Private Sub Worksheet_calculate()
If Range("$be8").Value = 1 Then
Application.EnableEvents = True
Call Macro(myRow)
Application.EnableEvents = False
End If
If Range("$bf8").Value = 1 Then
Application.EnableEvents = True
Call Macro(myRow)
Application.EnableEvents = False
End If
If Range("$bg8").Value = 1 Then
Application.EnableEvents = True
Call Macro(myRow)
Application.EnableEvents = False
End If
End Sub
Sub Macro(myRow)
Sheets("Calc. 1").Rows("11:11").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.Wait (Now + TimeValue("0:00:05"))
Rows("7:7").Copy
Rows("11:11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
'Range("B2").Select
Sheets("Calc.").Range("A" & CStr(myRow) & ":Q50002").Copy
Range("A3").Select
ActiveSheet.Paste
Calculate
Range("AZ3").Copy
Range("BA3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
'Range("B1").Select
Workbooks.Add
DoEvents
End Sub
it'still ugly, but now, you just have 1 main procedure instead of 40, and I cleaned a little bit. I also did comment the useless selects.
Next question : what does it do? Seems like it
inserts the row 11, then copies the row 7 into. That one shall not be problematic.
Copies a specific cell from another sheet to the current sheet. Well, why not.
Calculates. Here we have a problem. I have no clue of your calculations, and there very well might be circular things here, or insane amounts of calculations to do. Especially when I see hard-coded values going to the 50000th row... The wolf may hide here. Depends on your worksheet. This is my first suspect.
Copy another cell in the main sheet. No risk here.
Add an empty workbook. Without anything. Hum, are you sure? If your 40 values are positive, you dynamically open 40 workbooks, without naming them, or putting any data in them??? This is my second and last suspect.
Now, you have to troubleshoot yourself to know which suspect is guilty. For that, you can add breakpoints on a few strategic lines of the macro, to see what takes time(my bet on the calculate, but I may be wrong). Especially before & after the calculate & the Workbook.add
But ask yourself is everything I listed is useful, especially the calculate part, and especially the workbook.add part. Your macro might very well flood the computer memory with all those workbooks open in memory that are still useless.

Related

Why can I not reference a sheet name all of a sudden after over a year of running this Macro?

'-2147319767 (80028029)':
Been using this code for over a year now. Suddenly today, it gets the above run-time error when calling out certain sheet names or calling out Activesheet.
Absolutely no idea why it decided not to function today.
'''
Sheets("WIP Shortage").Select
Range("A:CB").Select
Selection.Delete Shift:=xlUp
Range("CC1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("CC1").Select
Selection.NumberFormat = "yyyy m-d;#"
ChDir "S:\Skim Kits\WIP Shortage Report"
Workbooks.Open Filename:= _
"S:\Skim Kits\WIP Shortage Report\" & Range("CC1").Text & " GEUD_WIP_Job_Shortage_Shop_Fl_ELO.xlsx"
Range("CC1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("CC1").Select
Selection.NumberFormat = "yyyy m-d;#"
Range("CC2").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("CC2").Select
Selection.NumberFormat = "yyyy-m-d;#"
Cells.Select
Selection.Copy
Windows("Availability-Shortages" & Range("CC2").Text).Activate
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("CD2").Select
ActiveCell.FormulaR1C1 = "=ISOWEEKNUM(RC[-76])"
Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown))
Windows(Range("CC1").Text & " GEUD_WIP_Job_Shortage_Shop_Fl_ELO.xlsx").Activate
ActiveWindow.Close
' Paste Thiswk Lastwk formula as values on QMI Targets
Application.Calculation = xlManual
Sheets("WIP Shortage").Select
Range("CE2").Select
ActiveCell.Formula = "=CD2+1"
Application.Calculation = xlAutomatic
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.Calculation = xlManual
Sheets("QMI TARGETS").Select
Range("AL2").Select
ActiveCell.Formula = "=SUMIFS('WIP Shortage'!L:L,'WIP Shortage'!K:K,A2,'WIP Shortage'!E:E,""OP"",'WIP Shortage'!CD:CD,ISOWEEKNUM(NOW()))"
Selection.Copy
Range("AL2:AL300").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.Calculation = xlAutomatic
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.Calculation = xlManual
Range("AM2").Select
ActiveCell.Formula = "=SUMIFS('WIP Shortage'!L:L,'WIP Shortage'!K:K,A2,'WIP Shortage'!E:E,""OP"",'WIP Shortage'!CE:CE,ISOWEEKNUM(NOW()))"
Selection.Copy
Range("AM2:AM300").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.Calculation = xlAutomatic
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'''
This is an excerpt from the entire code, but that first line is the first of 4 places it faults out. If I debug and manual select the sheet and move down the to the next line and run, it goes fine until I try to call out active sheet on line 23.
This is the code that precedes it and it runs fine. You'll notice it calls out my "today" sheet just fine and even renames it.
'''
Sheets("Today").Select
If Range("C5") = "Fri" Then
Sheets("Fri").Select
If Range("C5") = "Fri" Then
Sheets("Fri").Select
ActiveWindow.SelectedSheets.Delete
End If
End If
'''

In Private Sub on change in specific cells, the macro which is being called, goes back to private sub without completion of macro

I have a Private sub which calls a specific macro on change in cell value. However, when it calls the macro, the macro runs party and then automatically switches to beginning of private sub without going through all the lines of the macro. Not sure why that is happening. I am not a pro in vba but have done lots of practice. So sorry if this sounds to be a stupid question. Thank you!
Regards,
Aanand
Here's the private sub:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("K2:N2")) Is Nothing Then
Call RetrieveActual
End If
End Sub
Here's the macro:
Sub RetrieveActual()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Actual hours Database").Select
Range("A904857").End(xlUp).Offset(0, 7).Select
ActiveCell.FormulaR1C1 = "=RC[-7]&RC[-6]"
Selection.Copy
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Actual hours").Select
Range("C7").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('Actual hours Database'!C3:C5,MATCH('Actual hours'!R5C&'Actual hours'!RC35,'Actual hours Database'!C8,0),MATCH('Actual hours'!RC2,'Actual hours Database'!R1C3:R1C5,0)),0)"
Selection.Copy
Range("C7:AG9").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C11:AG13").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C15:AG17").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C19:AG21").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C23:AG25").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C27:AG29").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C31:AG33").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C35:AG37").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C39:AG41").Select
Selection.PasteSpecial Paste:=xlPasteFormulas
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Actual hours Database").Select
Columns("H:H").ClearContents
Sheets("Actual hours").Select
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Use:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("K2:N2")) Is Nothing Then
Call RetrieveActual
End If
Application.EnableEvents = True
End Sub
NOTE:
As a matter of programming style for event code, I suggest:
always beginning and ending event code with the disable/enable
only exiting the code from the bottom

Looping until cell is empty

I have my macro written but now I need it to run in a loop until cell I2 is empty.
Can anyone help with this?
Sheets("Value Imported Data").Select
Range("I2:Q2").Select
Selection.Copy
Sheets("Good data").Select
Range("I1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Value Imported Data").Select
ActiveCell.Resize(40, 9).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
I assumed it would be something like this but it does not work at all
Sub CandidatesInfo()
Dim r As Range
Dim Cell As Range
Sheets("Value Imported Data").Select
Set r = Range("I2")
For Each Cell In r
If r.Notempty Then
Range("I2:Q2").Select
Selection.Copy
Sheets("Good data").Select
Range("I1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Value Imported Data").Select
ActiveCell.Resize(40, 9).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If
Next
End Sub
Basically what I want to do is if I2 is empty do nothing but if it is not empty copy I2 to Q2 into another sheet and once copied go back in the sheet where the information was copied and delete the next 40 information down and 9 to the right and start over again. As I said the top macro works perfectly, now it is just a matter of starting over and over until I2 is empty.
Any help is appreciated.
Thank you very much

How to create loop in excel for copy paste

I'm trying to copy and past transpose and there is many rows.
The following code get from record macro, how to create loop upto L1000:N1000 in sheet2?
Sub Macro4()
Sheets("sheet2").Select
Range("L5:N5").Select
Selection.Copy
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("sheet2").Select
Range("L6:N6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B14").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("sheet2").Select
Range("L7:N7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.SmallScroll Down:=6
Range("B24").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
Since you are copying across as Paste Special Paste:=xlPasteAll, Transpose:=True, I retained that to keep your formulas and formatting. If only values were desired to be brought across in a transposed array, there are other methods that would be faster.
This starts with the destination as B4 and adds 10 rows to each successive loop; e.g. B4, B14, B24, etc.
Sub Copy_From_WS1_to_WS2_by_10()
Dim rw As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Sheets("Sheet1")
For rw = 4 To 1000
.Cells(rw, 12).Resize(1, 3).Copy
Sheets("Sheet2").Cells(4 + (rw - 4) * 10, 2).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
Next rw
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I've returned the calculation mode to Automatic at the end of the macro. Remove or comment that line if you wish it to remain manual.

Copy and Paste value when it changes

I am looking to write a code to :
copy cell A14 into the first row of column H,
move down the entire column (most recent data on top),
and then time stamp in column I when the value changes
But I cannot seem to get it running and working properly.
I am trying to keep real time tracking of these values and create a time series graph.
This needs to execute on its own.
Any thoughts?
Private Sub Gain(ByVal target As Range)
Application.EnableEvents = True
Do While cell("A14") <> cell("H1")
If cell("H1") <> cell("A14") Then
Range("H1:J1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A14").Select
Selection.Copy
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A16").Select
Application.CutCopyMode = False
Selection.Copy
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B16").Select
Application.CutCopyMode = False
Selection.Copy
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("I:I").Select
Application.CutCopyMode = False
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Columns("J:J").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("H:H").Select
Selection.NumberFormat = "$#,##0.00"
Next
End Sub
This will track any changes and paste the current time in Column I. It looks like your copying and pasting code should be working; if not, please let us know what (if any) errors or results you are getting.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
rng = Range("A:A")
If Intersect(Target, rng) Is Nothing Then
'Do nothing
Else:
If Target.Value <> Now Then
Cells(Target.Row, 9).Value = Now
Cells(Target.Row, 9).NumberFormat = "hh:mm:ss"
Else
End If
End If
End Sub

Resources