Macro met geavanceerd filter over meerdere werkbladen

[M. Kunis]

Ik wil een vraag voorleggen omdat ik vastloop met mijn macro. Het betreft een keuringsrapport voor noodverlichting dat ik moet maken.

Uitgangspositie:

- Ik heb een Excel file met een aantal werkbladen: Voorblad | Tekstblad | Kelder | Begane grond | Verd 1+2 | Afkeurpunten
- Voorblad, Tekstblad en Afkeurpunten staan vast, de tussenliggende werkbladen zijn variabel in aantal en inhoud. Op deze tussenliggende werkbladen wil ik een geavanceerd filter toepassen op kolom C ("Fout"), kopiëren en de uitkomst plakken op het laatste werkblad “Afkeurpunten”.


Stand van zaken:

- Het lukt mij om de gegevens van één werkblad d.m.v. een geavanceerd filter te kopiëren en te plakken op het werkblad Afkeurpunten.
- Het lukt mij NIET om hier een loop van te maken zodat alle gegevens onder elkaar op het werkblad Afkeurpunten komen.

Dit is mijn code:
Sub UseAdvancedFilterCopyAll()

Dim rgData As Range, rgCriteria As Range, rgOutput As Range

Set rgData = ThisWorkbook.ActiveSheet.Range("A5").CurrentRegion
Set rgCriteria = ThisWorkbook.ActiveSheet.Range("K1").CurrentRegion
Set rgOutput = ThisWorkbook.Worksheets("Afkeurpunten").Range("A3:G3")

rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput

End Sub

De rest van mijn geëxperimenteer heb ik maar achterwege gelaten.

Kan iemand mij helpen?

Kan ik mijn document ergens uploaden?

[ Voor 2% gewijzigd door M. Kunis op 24-03-2022 14:54 . Reden: Zin toegevoegd ]

[dix-neuf]

Bepaal voor het begin van elke kopieeractie de eerste lege rij op het blad waarheen je kopieert en plak daar je gegevens.

[LievenD]

Als de code die je hierboven gepost hebt werkt zoals het hoort, zou ik het zo proberen:

code:

Sub UseAdvancedFilterCopyAll()

*   Dim Blad As Integer
    Dim rgData As Range
    Dim rgCriteria As Range
    Dim rgOutput As Range

*   For Blad = 3 To Sheets.Count - 1
*       Set rgData = ThisWorkbook.Worksheets(Blad).Range("A5").CurrentRegion
*       Set rgCriteria = ThisWorkbook.Worksheets(Blad).Range("K1").CurrentRegion
*       Set rgOutput = ThisWorkbook.Worksheets("Afkeurpunten").Range("A" & Blad & ":G" & Blad)

        rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput
*   Next Blad

End Sub

De regels met een sterretje voor werden aangepast. Het spreekt voor zich dat je de sterretjes niet moet overnemen.

Het eerste sterretje maakt een nieuwe variabele Blad aan met als gegevenstype Integer.

Het tweede sterretje begint een For-lus op het derde blad (het eerste blad noemt Voorblad, het tweede blad noemt Tekstblad, en alle bladen daarna kan er data staan om te filteren, behalve het laatste blad, want dat is het blad Afkeurpunten) die moet eindigen op het voorlaaste blad (totaal aantal bladen - 1)

Bij het derde en vierde sterretje heb ik de naam van het werkblad gewijzigd naar de variabele Blad.

In het vijfde sterretje kwam de output van het eerste te filteren blad in jouw voorbeeld op A3:G3, dat betekent dat de output van het derde blad dus op rij 3 komt. Bijgevolg moet de output van het vierde blad op rij 4 komen, enzovoort. Omdat deze 'rijteller' gelijk is aan de 'bladteller' gebruik ik gewoon Blad om de rij te bepalen.

Het zesde sterretje tenslotte zorgt ervoor dat de For-lus uit het tweede sterretje juist wordt afgesloten.

Kan je eens zien of deze code enigszins naar behoren werkt?

[ Voor 4% gewijzigd door LievenD op 26-03-2022 18:58 . Reden: kleine update ]

[Lustucru]

LievenD schreef op zaterdag 26 maart 2022 @ 18:51:
In het vijfde sterretje kwam de output van het eerste te filteren blad in jouw voorbeeld op A3:G3, dat betekent dat de output van het derde blad dus op rij 3 komt. Bijgevolg moet de output van het vierde blad op rij 4 komen, enzovoort. Omdat deze 'rijteller' gelijk is aan de 'bladteller' gebruik ik gewoon Blad om de rij te bepalen.

Dat gaat alleen maar goed als er op elk werkblad precies één afkeurpunt is. Dat lijkt niet het geval. Je moet dus voor de kopieeraktie bepalen wat de doelrij wordt. Dat kan, zoals @dix-neuf aangeeft, met lastusedcell / xlUP (voorbeelden zat hier op het forum), of je telt na het toepassen van het filter het aantal zichtbare cellen met VisibleFilteredRowCount = rngdata.specialCells(xlVisible).Rows.Count maar misschien is het ook wel zo simpel als tellenhoevaak het woordje afkeur voorkomt op het bronblad.

[LievenD]

Klopt, maar dat heb ik uit het voorbeeld gehaald. Als daar had gestaan A3:G25 bijvoorbeeld, dan had ik daar mee rekening gehouden.

Zou het volgende beter werken?

code:

Sub UseAdvancedFilterCopyAll()

    Dim Blad As Integer
    Dim Rij As Integer
    Dim rgData As Range
    Dim rgCriteria As Range
    Dim rgOutput As Range
 
    Rij = 2

    For Blad = 3 To Sheets.Count - 1
        Set rgData = ThisWorkbook.Worksheets(Blad).Range("A5").CurrentRegion
        Set rgCriteria = ThisWorkbook.Worksheets(Blad).Range("K1").CurrentRegion
        Do
            Rij = Rij + 1
            If ThisWorkbook.Worksheets("Afkeurpunten").Range("A" & Rij).Value = "" Then   
                Set rgOutput = ThisWorkbook.Worksheets("Afkeurpunten").Range("A" & Rij & ":G" & Rij)
                Exit Do
            End If
        Loop
        rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput
    Next Blad

End Sub

[M. Kunis]

Dank voor de reacties.

@ LievenD:

De oplossing van 26/3 geeft helaas een foutmelding die ik niet kan traceren.

De oplossing van 27/3 werkt wel maar geeft te veel output;
- de kolomkoppen uit de werkbladen worden steeds meegekopieerd op het werkblad Afkeurpunten, maar dat hoeft niet want die staan er al boven
- vanwege bovenstaande komen ook de kolomkoppen van de werkbladen zonder afkeurpunten terug, dus verder leeg
- de loop wordt 2x uitgevoerd

Wat kan ik nog aan de code veranderen?

[Ronenmon]

maak van elk blad een excel tabel en gebruik de excel filter functie, is volgens mij een stuk eenvoudiger

[LievenD]

Voor wat betreft de kolomkoppen, zou ik op regel 9 in plaats van 'Rij = 2' eens 'Rij = 4' proberen.

Verder is mij niet helemaal duidelijk wat je bedoelt met 'de loop wordt tweemaal uitgevoerd'.
Welke gegevens krijg je tweemaal te zien?

[M. Kunis]

@LievenD :

Bij Rij = 4 i.p.v. Rij = 2 wordt de output een rij lager geplaatst. Maar ik krijg nog steeds de kolomkoppen van alle werkbladen ertussen.

De loop wordt tweemaal uitgevoerd: ik krijg alle output dubbel.

Kan ik op deze site mijn Excelfile ergens uploaden?

[M. Kunis]

De dubbele loop is opgelost!!
Nu alleen nog de kolomkoppen die ik er niet tussen wil hebben.

[dix-neuf]

M. Kunis schreef op maandag 4 april 2022 @ 10:10:
Kan ik op deze site mijn Excelfile ergens uploaden?

Je kunt bijvoorbeeld je file via WeTransfer uploaden en alleen een link laten aanmaken.
Als je die link hier plaatst kunnen geïnteresseerden via die link je file downloaden.

[F_J_K]

Uploaden van foto's / plaatjes wel, maar geen andere bestanden. Dat kan op een van de vele (vaak gratis) file sharing sites en dan hier een link plaatsen. Maar er zullen weinig mensen bereid zijn om een 'willekeurig' Excelbestand met macro's te downloaden en openen, dat is hoe malware op PC's komt.

Sowieso is het beter om alleen de relevante delen van sheets en code te geven.

Als je ten onrechte de koppen krijgt, kan je misschien rgData inperken. En geen CurrentRegion gebruiken maar concrete ranges zelf opgeven, Denk ik, ik heb die functie nooit gebruikt. Of de naam vd kop aanpassen zodat het buiten de zoekresultaten valt?

[dix-neuf]

F_J_K schreef op maandag 4 april 2022 @ 11:07:
Uploaden van foto's / plaatjes wel, maar geen andere bestanden.

Dat wist ik niet. Ik meende me te herinneren dat ik in het verleden op die manier een Wordbestand heb binnengehaald. Maar dan heb ik me wellicht vergist.

[F_J_K]

dix-neuf schreef op maandag 4 april 2022 @ 11:19:
[...]
Dat wist ik niet. Ik meende me te herinneren dat ik in het verleden op die manier een Wordbestand heb binnengehaald. Maar dan heb ik me wellicht vergist.

offtopic:
My bad: ik reageerde op de TS. WeTransfer o.i.d. werkt inderdaad. Al ben ik in ieder geval niet bereid andermans .xlsm te openen. Da's niet veilig te doen. (Al heb ik natuurlijk alle vertrouwen dat @M. Kunis geen malware verstuurt, het gaat om het principe).

[M. Kunis]

Dit is de link naar mijn file:

https://we.tl/t-WDNkSyBZiz

Het gaat er dus alleen nog om dat de kolomkoppen op het blad Afkeurpunten na het uitvoeren van de macro Sub UseAdvancedFilterCopyAll3003() niet steeds herhaald worden.

[LievenD]

Ik vond niet direct een mooie oplossing, maar met een beetje 'gehack' (d.w.z. de kolomkoppen achteraf verwijderen) werkt het nu wel zoals het hoort.
Zie hieronder:

code:

Sub UseAdvancedFilterCopyAll()

    Dim Blad As Integer
    Dim Rij As Integer
    Dim SaveRij As Integer
    Dim Lijn As Integer
    Dim rgData As Range
    Dim rgCriteria As Range
    Dim rgOutput As Range
 
    Rij = 3

    For Blad = 3 To Sheets.Count - 1
        Lijn = 0
        Set rgData = ThisWorkbook.Worksheets(Blad).Range("A5").CurrentRegion
        Set rgCriteria = ThisWorkbook.Worksheets(Blad).Range("K1").CurrentRegion
        Do
            Rij = Rij + 1
            If ThisWorkbook.Worksheets("Afkeurpunten").Range("A" & Rij).Value = "" Then
                Lijn = Lijn + 1
                If Lijn = 1 Then SaveRij = Rij
                Set rgOutput = ThisWorkbook.Worksheets("Afkeurpunten").Range("A" & Rij & ":G" & Rij)
                Exit Do
            End If
        Loop
        rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput
        ThisWorkbook.Worksheets("Afkeurpunten").Rows(SaveRij).Delete
    Next Blad

End Sub

[M. Kunis]

@LievenD
Het werkt nu naar behoren. Dankjewel voor je inspanningen bij het oplossen van mijn VBA probleem..

[dix-neuf]

Met gebruikmaking van wat ik in mijn eerste bericht hierboven schreef:

code:

Sub Test()
Dim x As Integer, y As Integer, lr1 As Integer, lr2 As Integer
With Sheets("Afkeurpunten")
lr2 = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A4:G" & lr2).ClearContents
End With
For x = 3 To Sheets.Count - 1
With Sheets(x)
lr1 = .Range("A" & .Rows.Count).End(xlUp).Row
For y = 5 To lr1
If .Range("C" & y).Value = .Range("K2").Value Then
With Sheets("Afkeurpunten")
lr2 = WorksheetFunction.Max(4, .Range("A" & .Rows.Count).End(xlUp).Row + 1)
Sheets(x).Range("A" & y & ":G" & y).Copy .Range("A" & lr2)
End With
End If
Next y
End With
Next x
End Sub

Opm:
1. Pas op met het het samenvoegen van cellen als je vba gebruikt, dat kan tot problemen leiden als die cellen in de vba-code worden betrokken.
2. Als je je eigen (aangepaste) macro wil blijven gebruiken, kijk dan in je Excelbestand eens naar de gebruikte namen. Sommige komen meer dan1 keer voor, verwijzend naar verschillende cellen en/of werkbladen; en andere zijn niet goed gedefinieerd waardoor er een foutmelding bij staat.
3. De oorzaak dat bij jouw (aangepaste) macro de koppen van de bladen 3 t/m 5 mee worden gekopieerd, is deze regel:

code:

Set rgData = ThisWorkbook.Worksheets(Blad).Range("A5").CurrentRegion

De 'CurrentRegion' van Range("A5") begint op de bladen 3 t/m 5 bij A3.

[ Voor 11% gewijzigd door dix-neuf op 04-04-2022 17:53 ]

[M. Kunis]

Deze werkt helemaal super, dix-neuf. Bedankt voor je hulp.