Macro using too much memory

Brass Contributor

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

@Change99 

Try avoiding cells/ranges as much as possible. For example,

    Columns("A:H").Select
    Selection.Delete Shift:=xlToLeft

can be shortened to

    Columns("A:H").Delete Shift:=xlToLeft

And

.SpecialCells(xlCellTypeConstants, 2).Select
End With

Selection.EntireRow.Delete

can be shortened to

.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
End With

@Hans Vogelaar 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 Sub




@Change99 

You are still selecting a lot of ranges in your code...

Ah right! Ill update you after changing that!

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 Sub

Don'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?

 

The complete Guide to Excel VBA Sub and how to use it (excelmacromastery.com)

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.

Thanks Ill check it out!