Macro maakt Excel traag

[Peter Bulthuis]

Ik heb twee macro's in een Excelsheet die ik veelvuldig gebruik, maar Excel behoorlijk traag maken. Ik heb de macro's gekoppeld aan knoppen, zodat ik daarop kan drukken om ze te activeren.




In een lijst heb ik sommige onderwerpen voorzien van een |

Het is de bedoeling dat de eerste macro alle onderwerpen met | aan het eind, filtert.

Dat ziet er dan zo uit: (Zie ook afbeelding)

Project01|
Project02|
Project03|
Project04|
Project05|

Nu selecteer ik bijvoorbeeld Project03| en druk daarna op macro 2. Deze filtert alle items die beginnen met Project03|

Dat komt er dan bijvoorbeeld zo uit te zien:

Project03|Onderwerp01
Project03|Onderwerp02
Project03|Onderwerp03
Project03|


Als ik de macro's voor de eerste keer activeer, werkt het zoals het hoort: snel. Maar als ik ze redelijk achter elkaar activeer, wordt Excel steeds trager totdat de macro z'n werk heeft gedaan. Dus, ik druk op macro 1, krijg ik de projectlijst te zien. Klik ik op een project en daarna op macro 2, dan krijg ik dus de lijst met onderwerpen die in die project zitten. Klik ik daarna weer op macro 1 om een ander project te selecteren en daarna weer op macro 2 om de onderwerpen in dat project te bekijken en zovoort, duurt het steeds langer voordat de macro klaar is. En wordt Excel in tussentijd erg traag.

Waar kan dit aan liggen? Bij andere macro's die ik heb gemaakt in dezelfde sheet heb ik geen enkel probleem. Ligt het aan de macro's? Wat zou daar anders aan moeten?

Met vriendelijke groet,

Peter



Dit is macro 1:

Sub Hoofdprojecten()
'
' Hoofdprojecten Macro
' De macro is opgenomen op 79-2-2012 door P.Bulthuis.
'

'
    screenupdate = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Range("A6").Copy
    Range("J2").Select
    ActiveSheet.Paste
    Range("J2").FormulaR1C1 = "=""=*|"""
    Range("I2").FormulaR1C1 = "<>[Thema]"
    
    Range("A9:R2000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Rows("1:2"), Unique:=False
    Range("J2").ClearContents
    Range("I2").ClearContents
    Range("A9:R2000").Sort Key1:=Range("C9"), Order1:=xlAscending, Key2:=Range _
        ("L9"), Order2:=xlAscending, Key3:=Range("H9"), Order3:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
        xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
        DataOption3:=xlSortNormal
    Application.Calculation = xlCalculationAutomatic
    screenupdate = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    End Sub

Dit is macro 2:

Sub Test()
'
' Filter01 Macro
' De macro is opgenomen op 9-2-2012 door P.Bulthuis.
'

'
On Error GoTo ErrorHandler

    screenupdate = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Selection.Copy
    Range("J6").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("K6").FormulaR1C1 = "=LEFT(RC[-1],SEARCH(""|"",RC[-1],1))"
    Range("K6").Copy
    Range("J2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A9:R2000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Rows("1:2"), Unique:=False
       
       
        Range("A9:R2000").Sort Key1:=Range("J9"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
        Range("A9:R2000").Sort Key1:=Range("B9"), Order1:=xlAscending, Key2:=Range _
        ("A9"), Order2:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
    Range("J2").ClearContents
    Range("J6").ClearContents
    Range("K6").ClearContents
    Application.Calculation = xlCalculationAutomatic
    screenupdate = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
    Exit Sub
    
ErrorHandler:
   Range("A2").ClearContents
    Range("K6").ClearContents
    Range("J6").Copy
    Range("J2").Paste
    Application.CutCopyMode = False
    Range("A9:R2000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Rows("1:2"), Unique:=False
    Range("J2").ClearContents
    Range("J6").ClearContents
    Range("K6").ClearContents
    Exit Sub
   End Sub

 

[Roncancio]

Kan je het bestand bijsluiten?

Met vriendelijke groet,


Roncancio

 

[snb]

CriteriaRange:=  range("I1:J2")

wat staat er in cel I1 en J1 ?

als je alleen waarden wil 'kopiëren' vermijd dan 'copy' maar gebruik bijv.

range("A1")=range("B20").value

 

[huijb]

@Peter Bulthuis Code dient tussen de codetags geplaatst te worden. Hiermee is het beter leesbaar voor de helpers. Zie ook hier http://www.helpmij.nl/forum/showthr...-de-helpers-in-deze-sectie-van-dienst-te-zijn

 

[Peter Bulthuis]

Bedankt voor alle antwoorden. Inmiddels heb ik het probleem (zo goed als) kunnen oplossen.