May 11 2021 05:30 AM - edited May 11 2021 05:36 AM
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
May 11 2021 07:12 AM
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
May 12 2021 02:56 AM
@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
May 12 2021 03:00 AM
You are still selecting a lot of ranges in your code...
May 12 2021 06:30 PM - edited May 12 2021 06:38 PM
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
May 20 2021 11:52 PM - edited May 20 2021 11:56 PM
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.