Macro geheugen probleem

[wouter1983]

Ik heb de onderstaande macro met een For Next loop erin. Bij de eerste loop geeft Taakbeheer al aan dat er meer dan 1 GB geheugen wordt gebruikt. Na een aantal loops krijg ik een foutmelding dat er niet voldoende geheugen (onvoldoende bronnen) is.

Waar in de macro ga ik de mist in? Of is er een mogelijkheid om tussen de loops door het geheugen vrij te maken?

Sub AlleTPs()
    
    'Stap 1: Beveiliging verwijderen
    Workbooks("Dashboard 2011.xlsm").Sheets("Selectie").Unprotect
    Workbooks("Dashboard 2011.xlsm").Sheets("Dash 1").Unprotect
    Workbooks("Dashboard 2011.xlsm").Sheets("Dash 2").Unprotect
    Workbooks("Dashboard 2011.xlsm").Sheets("Dash 3").Unprotect

        'Stap 2: Begin van de loop
        For Each Cell In Worksheets("W Bron").Range("A2:A600")
    
            'Stap 3: Controle op lege cel in Loop lijst.
            '        Geen lege cel; loop gaat door
            '        Wel lege cel; loop stopt en Beveiliging wordt toegevoegd
            If IsEmpty(Cell) Then
            Workbooks("Dashboard 2011.xlsm").Sheets("Selectie").Protect
            Workbooks("Dashboard 2011.xlsm").Sheets("Dash 1").Protect
            Workbooks("Dashboard 2011.xlsm").Sheets("Dash 2").Protect
            Workbooks("Dashboard 2011.xlsm").Sheets("Dash 3").Protect
            MsgBox "Uw Dashboards zijn gedraaid.", vbOKOnly, "Wouter zegt"
            Exit For
            End If
            
            'Stap 4: Kopieer waarde cell naar D4
            Worksheets("Selectie").Range("D4") = Cell
            
            'Stap 5: Maak tabblad Draaitabellen bron leeg
            Sheets("Draaitabellen bron").Range("A:CJ").ClearContents
                
            'Stap 6: Voert Uitgebreid filter uit op C bron
            Sheets("C Bron").Range("A1:CH10000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheets("Filter").Range("A1:CH2"), Unique:=False
            
            'Stap 7: Plakt resultaat filter in Draaitabellen bron
            Sheets("C Bron").Range("A:CH").Copy Destination:=Sheets("Draaitabellen bron").Range("A:CH")
            
            'Stap 8: Netto kolom toevoegen
            Sheets("Draaitabellen Bron").Range("CI1").FormulaR1C1 = "Netto"
            Sheets("Draaitabellen Bron").Range("CI2:CI1000").FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""netto"",RC[-37])),""Ja"",""Nee"")"
            
            'Stap 9: Vernieuwd het hele Workbook
            ActiveWorkbook.RefreshAll
            
            'Stap 10: Exporteert de resultaten naar PDF
            Sheets(Array("Dash 1", "Dash 2")).Select
            With ActiveSheet
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                "K:\Dashboard\Dashboard 2011\" & Sheets("Selectie").Range("G4").Value & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                :=False, OpenAfterPublish:=False
            End With
            
            'Stap 11: Terug naar Neutraal
            Sheets("Selectie").Select
        
        'Stap 12: Terug naar begin van loop
        Next Cell
 
End Sub

 

[Warme bakkertje]

Al eens geprobeerd om ipv te filteren in je tabel en dan een hele hoop volledige kolommente kopieëren, ineens het resultaat te filteren naar tabblad Draaitabellen Bron ?

 

[wouter1983]

Nee nooit geprobeerd. Eerlijk gezegt nooit geweten dat het kon.

Ik heb trouwens wel het geheugen probleem opgelost inmiddels.

'Stap 7: Plakt resultaat filter in Draaitabellen bron
Sheets("C Bron").Range("A1:CH10000").Copy Destination:=Sheets("Draaitabellen bron").Range("A1:CH10000")

In de Range een cellenbereik aangegeven. Nu draait deze als een zonnetje.

Zou je me op weg kunnen helpen en een voorbeeld kunnen geven van van het resultaat van de filter ineens te kopieren?

Alvast bedankt.