Forum Discussion
Macro using too much memory
Dear Excel experts,
I have a few macros witch I stitched together in one big macro. It does work, however sometimes it crashes. Any idea on how to make it more effcient? I would greatly appreciate any input!
Sub ActivateSheet()
Worksheets("DPW_reinkopieren").Activate
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
dpwlöschenkopierenfiltern
End Sub
Sub dpwlöschenkopierenfiltern()
'
' dpwlöschenkopierenfiltern Makro
'
'
Application.CutCopyMode = False
Columns("A:H").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("E:G").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.AutoFilter
ActiveSheet.Range("$D$1:$D$136").AutoFilter Field:=1, Criteria1:= _
"direkte TN/innen-bezogene Leis"
Columns("A:C").Select
Selection.Copy
Sheets("DPW").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("LDP").Select
ActivateSheet2
End Sub
Sub ActivateSheet2()
Worksheets("LDP_reinkopieren").Activate
ldplöschenfiltern
End Sub
Sub ldplöschenfiltern()
'
' ldplöschenfiltern Makro
'
'
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("D:H").Select
Selection.Delete Shift:=xlToLeft
Columns("E:H").Select
Selection.Delete Shift:=xlToLeft
Columns("A:D").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$1165").AutoFilter Field:=4, Criteria1:="<>"
Columns("A:C").Select
Selection.Copy
Sheets("LDP_Nullen").Select
Range("A1").Select
ActiveSheet.Paste
Columns("A:C").Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$1048408").AutoFilter Field:=3, Criteria1:=">0", _
Operator:=xlAnd
ActiveSheet.Range("$A$1:$C$1048408").AutoFilter Field:=2, Criteria1:=">0", _
Operator:=xlAnd
Columns("A:C").Select
Selection.Copy
Sheets("LDP").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("LDP").Select
Macro2
End Sub
Sub Macro2()
'
'
'
'
Range("D2:D7").Select
Selection.FormulaR1C1 = _
"=IF(AND(RC[-3]=R[-1]C[-3],RC[-2]=R[-1]C[-1],R[-1]C<>""Delete""),""Delete"",IF(AND(R[1]C[-3]=RC[-3],R[1]C[-2]=RC[-1]),R[1]C[-1],RC[-1]))"
Macro1
End Sub
Sub Macro1()
On Error GoTo Quit
MyLoop:
LR = Cells(Rows.Count, 1).End(xlUp).Row
With Range("D2:D" & LR)
.FormulaR1C1 = _
"=IF(AND(RC[-3]=R[-1]C[-3],RC[-2]=R[-1]C[-1],R[-1]C<>""Delete""),""Delete"",IF(AND(R[1]C[-3]=RC[-3],R[1]C[-2]=RC[-1]),R[1]C[-1],RC[-1]))"
.Value = .Value
.Offset(0, -1).Value = .Value
.SpecialCells(xlCellTypeConstants, 2).Select
End With
Selection.EntireRow.Delete
LR2 = Cells(Rows.Count, 1).End(xlUp).Row
If LR2 < LR Then GoTo MyLoop
Quit:
Range("D2:D" & LR).Clear
'Application.Wait (Now + TimeValue("0:00:01"))
markierenLPD
End Sub
Sub markierenLPD()
'
' markierenLPD Makro
'
'
Cells.Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=A1<>DPW!A1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 192
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
Info:
Windows Version: Microsoft Windows 10 Pro
Excel Version: Microsoft Office Standard 2016
8 Replies
Hi Change99 ,
I'm not very familiar with VB, but if all subs and functions are in a module, wouldn't it be better to create a
Main Sub()Call Sub ActivateSheet()
IF .......
...
Then
...
Else
...
EndIf
Call Sub dpwlöschenkopierenfiltern()
And so on and so forth?
End SubDon't forget to add the Exit Sub in the Sub Procedures that you call so that it won't take up too much memory...
or am i just way too out of touch in this scene?
https://excelmacromastery.com/excel-vba-sub/
Cheers
- Where would you place the Exit Sub's?
Hi Change99
Click the link I provided and it will explain it to you
basically you put the exit sub in the procedures calls you are making in the main sub, the purpose for that is so your code will not be taking up memory waiting to be excuted and free up memory so excel wont keep rotating before it stops responding.
Try avoiding cells/ranges as much as possible. For example,
Columns("A:H").Select Selection.Delete Shift:=xlToLeftcan be shortened to
Columns("A:H").Delete Shift:=xlToLeftAnd
.SpecialCells(xlCellTypeConstants, 2).Select End With Selection.EntireRow.Deletecan be shortened to
.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End WithHansVogelaar Thank you very much! I changed the code as specified but unfortunately it still crashes when handling more data. Any further ideas? 🙂
Here the code so far:
Sub ActivateSheet() Worksheets("DPW_reinkopieren").Activate Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayStatusBar = False Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False dpwlöschenkopierenfiltern End Sub Sub dpwlöschenkopierenfiltern() ' ' dpwlöschenkopierenfiltern Makro ' ' Application.CutCopyMode = False Columns("A:H").Delete Shift:=xlToLeft Columns("B:B").Delete Shift:=xlToLeft Columns("D:D").Delete Shift:=xlToLeft Columns("E:G").Delete Shift:=xlToLeft Columns("D:D").Select Selection.AutoFilter ActiveSheet.Range("$D$1:$D$136").AutoFilter Field:=1, Criteria1:= _ "direkte TN/innen-bezogene Leis" Columns("A:C").Select Selection.Copy Sheets("DPW").Select Range("A1").Select ActiveSheet.Paste Sheets("LDP").Select ActivateSheet2 End Sub Sub ActivateSheet2() Worksheets("LDP_reinkopieren").Activate ldplöschenfiltern End Sub Sub ldplöschenfiltern() ' ' ldplöschenfiltern Makro ' ' Columns("A:A").Delete Shift:=xlToLeft Columns("D:H").Delete Shift:=xlToLeft Columns("E:H").Delete Shift:=xlToLeft Columns("A:D").Select Selection.AutoFilter ActiveSheet.Range("$A$1:$D$1165").AutoFilter Field:=4, Criteria1:="<>" Columns("A:C").Select Selection.Copy Sheets("LDP_Nullen").Select Range("A1").Select ActiveSheet.Paste Columns("A:C").Select Application.CutCopyMode = False Selection.AutoFilter ActiveSheet.Range("$A$1:$C$1048408").AutoFilter Field:=3, Criteria1:=">0", _ Operator:=xlAnd ActiveSheet.Range("$A$1:$C$1048408").AutoFilter Field:=2, Criteria1:=">0", _ Operator:=xlAnd Columns("A:C").Select Selection.Copy Sheets("LDP").Select Range("A1").Select ActiveSheet.Paste Sheets("LDP").Select Macro2 End Sub Sub Macro2() ' ' ' ' Range("D2:D7").Select Selection.FormulaR1C1 = _ "=IF(AND(RC[-3]=R[-1]C[-3],RC[-2]=R[-1]C[-1],R[-1]C<>""Delete""),""Delete"",IF(AND(R[1]C[-3]=RC[-3],R[1]C[-2]=RC[-1]),R[1]C[-1],RC[-1]))" Macro1 End Sub Sub Macro1() On Error GoTo Quit MyLoop: LR = Cells(Rows.Count, 1).End(xlUp).Row With Range("D2:D" & LR) .FormulaR1C1 = _ "=IF(AND(RC[-3]=R[-1]C[-3],RC[-2]=R[-1]C[-1],R[-1]C<>""Delete""),""Delete"",IF(AND(R[1]C[-3]=RC[-3],R[1]C[-2]=RC[-1]),R[1]C[-1],RC[-1]))" .Value = .Value .Offset(0, -1).Value = .Value .SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End With LR2 = Cells(Rows.Count, 1).End(xlUp).Row If LR2 < LR Then GoTo MyLoop Quit: Range("D2:D" & LR).Clear markierenLPD End Sub Sub markierenLPD() ' ' markierenLPD Makro ' ' Cells.Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=A1<>DPW!A1" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 192 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True ActiveSheet.DisplayPageBreaks = True End SubYou are still selecting a lot of ranges in your code...
