Excel loopt vast bij afspelen macro

[GercoTermaat]

Beste helper,

Ik ben bezig met een calculatiesheet waarbij veel informatie uit een rapport gekopieerd moet worden naar het calculatiesheet.
Ik heb een macro gemaakt die werkt, alleen bij het invoegen van grote rapporten duurt deze macro erg lang of Excel loopt gewoon vast.
Nu heb ik zeker al een week ervaring met macro's, dus weet er eigenlijk nog veel te weinig van af.
De code waar het om gaat is als volgt:

Sub Gereedschappen()

Application.ScreenUpdating = False
Range("AF2:AK2").AutoFill Destination:=Range("AF2:AK1000"), Type:=xlFillDefault
Range("BG2:BH2").AutoFill Destination:=Range("BG2:BH1500"), Type:=xlFillDefault
Range("BP1:BQ1").AutoFill Destination:=Range("BP1:BQ1500"), Type:=xlFillDefault

Range("AF1:AK1000").Copy
Range("Z1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

For i = Cells(Rows.Count, 26).End(xlDown).Row To 1 Step -1
If Range("Z" & i).Value = "@" Then
Range("Z" & i, "AE" & i).Cells.Delete xlUp
End If
Next
Range("W1,W22").FormulaR1C1 = "1"
Range("BF1:BF1000").FormulaR1C1 = "=CONCATENATE(RC[-29],RC[-28])"
 
Sheets("Rapport").Select
Dim Findstring As String
Dim Description As Range
Findstring = "--Description--"

With Worksheets("Rapport").Range("A1:N1500")
    Set Description = .Find(What:=Findstring, LookIn:=xlValues)
    If Description Is Nothing Then
    Sheets("Calculatiesheet").Select
    MsgBox ("Geen boorbewerkingen gevonden")
    Else
    Rows(Description.Row).SpecialCells(xlCellTypeConstants).AutoFilter Field:=2, Criteria1:="Drill"
    Union(Range(Description.Offset(1, -1), Description.Offset(1, -1).End(xlDown)), _
    Range(Description.Offset(1, 4), Description.Offset(1, 4).End(xlDown)), _
    Range(Description.Offset(1, 9), Description.Offset(1, 9).End(xlDown))).Copy
    
    Range("S1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Rows(Description.Row).AutoFilter
    Range("S1:U1500").Copy
    Sheets("Calculatiesheet").Select
    Range("BJ1").PasteSpecial
    Range("BH1:BH1500").Copy
    Range("BI1:BI1500").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
End If
End With
End Sub

Ik denk dat dit gedeelte erg lang duurt:

For i = Cells(Rows.Count, 26).End(xlDown).Row To 1 Step -1
If Range("Z" & i).Value = "@" Then
Range("Z" & i, "AE" & i).Cells.Delete xlUp
End If
Next

Wat hier gebeurt:
In de cellen AF1:AK1000 staan formules waarbij de benodigde gegevens opgehaald worden van het rapport. Hierin wil ik veel waardes niet zien dus deze vervang ik door een "@". Als in het rapport "totaal" staat onder aan de tabel, worden de cellen in AF:AK leeg. De cellen AF1:AK1000 worden gekopieerd naar de cellen in Z:AE. Hier begint het probleem. Ik wil alle cellen die "@" bevatten verwijderen en de rest omhoog schuiven, dit lukt prima, maar duurt erg lang. Is er een betere (snellere) manier op dit op te schrijven?


Mijn Excel bestand is 9611kb, dit lijkt me wel heel veel.

Alvast bedankt,
Gerco

 

[edmoor]

Dat zal zo wellicht een stuk sneller gaan:

Application.ScreenUpdating = False
For i = Cells(Rows.Count, 26).End(xlDown).Row To 1 Step -1
    If Range("Z" & i).Value = "@" Then
        Range("Z" & i, "AE" & i).Cells.Delete xlUp
    End If
Next

 

[GercoTermaat]

Edmoor,

Bedankt voor je snelle reactie.
Ik heb het aangepast, maar dit werkt helaas nog niet.
Screenupdating had ik ook al uit staan.
Toch bedankt voor de moeite.

 

[VenA]

Het verwijderen va max 1000 rijen duurt zelfs met de gekozen methode niet zolang. Jouw formules worden elke keer herberekend.
Dus eerst op handmatig zetten en aan het eind van de procedure weer op automatisch

Application.Calculation = xlManual
code
Application.Calculation = xlAutomatic

 

[HSV]

Zet er een filter op en verwijder de rijen ineens; zal aanmerkelijk sneller gaan.

 

[snb]

Ik vrees dat zelfs deze code overbodig is als je een duidelijker beeld schetst van de beginsituatie en de gewenste eindsituatie (bij 3 keer autofill kan ik me bijv. weinig voorstellen). Je kunt een werboek/werkblad nl. altijd als sjabloon voor een nieuw werkblad gebruiken.
Eerst gegevens kopiëren en dan weer verwijderen klinkt ook niet erg efficiënt.

 

[Ginger]

Naar mijn bescheiden mening kom je met deze opdracht Cells(Rows.Count, 26).End(xlDown).Row uit op de laatste regel van een worksheet...
Dan moet je dus een miljoen keer omhoog stappen en andere dingen doen voordat je bij je gekopieerde tabel bent. (maar ik kan het ook mis hebben natuurlijk)

 

[VenA]

Scherp gezien. Of kom je dan weer in rij 1 uit?:d

 

[GercoTermaat]

Goedemorgen,

Bedankt voor alle reacties.

Ik heb meerdere dingen geprobeerd, maar alles zonder succes.
Zelfs handmatig verwijderen van 4 cellen en de rest omhoog schuiven is momenteel te veel voor mijn computer.

Het rare vind ik dat deze code het aan het begin van de week gewoon goed deed, maar dat ik er nu niets meer mee kan.
Kan het iets zijn dat mijn bestand te groot geworden is?

 

[snb]

Zo te zien aan je geplaatste bestand .....

 

[GercoTermaat]

Update: Wat ik wil is toch gelukt via een andere manier. Hiermee ga ik niet de waardes van de formules in AF1:AK1000 kopieren, maar filter ik de waardes uit het rapport en kopieer deze automatisch in Z1:AE..
Eigenlijk is dit dezelfde methode als het eind van de code uit mijn eerste bericht.

Toch bedankt voor de moeite allemaal!
Groeten,
Gerco