Kolommen filteren op op zichtbare cellen Formule toepassen

[globe]

Het is weer tijd voor de Eindejaars lijstjes.

Ik heb een ellenlange lijst met artikelgroepen en artikelen die in deze groepen zitten.
Nu pas ik daar een formule op toe om de lege groepen te filter en te verwijderen.

Kolom A mag niet leeg zijn, en Kolom C moet leeg zijn.

Op de resultaten pas ik de formule =AANTAL.ALS(B:B;B2) in Kolom C (vanaf cel C2) toe.
Zo krijg ik te zien hoe vaak een bepaalde groep voorkomt in de data.
Alle rijen die "1" als resultaat geven dienen te worden verwijderd.
Daar filter ik dan Kolom C op en verwijder de rijen.

Nu heb ik onderstaande code gemaakt, maar krijg er helaas een foutmelding op.

OP de regel waar ik de formule plak krijg ik een: Methode van Object_Global is mislukt.

Sub Verwijder_lege_groep()

       With ActiveSheet.Range("A:C")
    .AutoFilter Field:=1, Criteria1:="<>"
    .AutoFilter Field:=3, Criteria1:=""
    
   Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
       
       End With
       
       With ActiveSheet.Range("A:C")
    .AutoFilter Field:=1, Criteria1:="<>"
    .AutoFilter Field:=3, Criteria1:="1"
    
       .Resize(Rows.Count - 1).Offset(1).EntireRow.Delete
       
          
    End With
  

  AutoFilterMode = False
End Sub

En dan zou ik graag dit script op alle sheets willen laten uitvoeren, dit varieert van 1 tot circa 40.

Wie helpt me uit de brand.

Dank!

 

[SjonR]

Hi Globe,

Waar haalt Lastrow zijn waarde vandaan?

 

[globe]

Ook goedemorgen... Die was ik helemaal vergeten aan te geven

Dat is dus het eerste gedeelte van de vraag, ga ik weer klussen om alle werkbladen te verwerken.

 

[JEC.]

Probeer deze eens

Sub jec()
 Dim r As Range
 With Cells(1).CurrentRegion
    Set r = .Offset(, .Columns.Count + 1).Resize(2, 1)
    r(2).Formula = "=(a2<>"""")*(c2="""")*countif(B:B,B2)=1"
    .AdvancedFilter 1, r
    .Offset(1).EntireRow.Delete
    .Parent.ShowAllData
    r.ClearContents
 End With
End Sub

 

[globe]

Dat is een fraaie JEC, dank je.

En ik zie nu dat sommige sheets lege regels bevatten die van mijn collega niet weg mogen, jouw script loopt stuk op lege regels.

Mijn script doet dat prima. heb nu het volgende:

Sub Verwijder_lege_groep()

ActiveSheet.AutoFilterMode = False

       With ActiveSheet.Range("A:C")
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
       
    .AutoFilter Field:=1, Criteria1:="<>"
    .AutoFilter Field:=3, Criteria1:=""
    
   Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
       
       End With
       
       With ActiveSheet.Range("A:C")
    .AutoFilter Field:=1, Criteria1:="<>"
    .AutoFilter Field:=3, Criteria1:="1"
    
       .Resize(Rows.Count - 1).Offset(1).EntireRow.Delete
       
          
    End With
  
 ActiveSheet.AutoFilterMode = False
End Sub

Wat jou script lekker doet is geen aantal laten staan.

Mag ik je verzoeken nog eens mee te denken?

Dank!

Guido

 

[JEC.]

Voor een beter beeld zou het voorbeeld bestand iets relevanter moeten zijn. Je kunt deze eens proberen

Sub jecc()
 Application.ScreenUpdating = False
 With Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 50)
   .Columns(50).Value = Evaluate(Replace("if((" & .Columns(1).Address & "<>"""")*(" & .Columns(3).Address & "="""")*countif(@,@)=1,""#N/A"","""")", "@", .Columns(2).Address))
    On Error Resume Next
   .Columns(50).SpecialCells(2, 16).EntireRow.Delete
 End With
End Sub

of

Sub jec()
 Dim r As Range
 With Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 3)
    Set r = .Offset(, 50).Resize(2, 1)
    r(2).Formula = "=(a2<>"""")*(c2="""")*countif(B:B,B2)=1"
    .AdvancedFilter 1, r
    .Offset(1).EntireRow.Delete
    .Parent.ShowAllData
    r.ClearContents
 End With
End Sub

 

[globe]

je hebt 100% gelijk, ik zag later pas dat er in sommige sheets lege regels zitten die moeten blijven bestaan.

Onderstaand voorbeeld is een gedeelte uit de werkelijk sheet.
In zwart zijn de groepen aangegeven met daaronder de artikelen uit deze groep.

Indien er geen artikelen onder staan moet de regel weg.

Ik zie nu dat in sommige sheets ook dubbele groepen staan waardoor mijn filter op AantalAls niet gaat werken.

 

[JEC.]

Terug naar de tekentafel zou ik zeggen

 

[globe]

je bedoelt, even met de zweep over de rug van mijn collega?

De data zal eerst beter gesorteerd moeten worden, dan werkt jouw script wel.

 

[JEC.]

Ja voor nu kun je deze nog proberen

Sub jec()
 Dim sp, it
 Set sp = Cells(9999, 1)
 
 For Each it In Range("A3", Range("A" & Rows.Count).End(xlUp))
   If (it <> "") * (it.Offset(, 2) = "") * (it.Offset(2, 2) = "") Then Set sp = Union(sp, it)
 Next
 sp.EntireRow.Delete
End Sub