Rijen verwijderen die ongelijk zijn

[DollyBD]

Goedmiddag,

Ik heb onderstaande code gevonden. Deze doet exact het tegenovegestelde van wat ik graag zou willen:

Sub RijenVerwijderen()
    
    Dim rTemp As Range
    Dim ws As Worksheet
    Dim firstAddress As String
    
    For Each ws In ThisWorkbook.Worksheets
    
        If ws.Index <> ActiveSheet.Index Then
                
            Set rTemp = ws.Columns(2).Find(ActiveCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            
            If Not rTemp Is Nothing Then
                
                firstAddress = rTemp.Address
                
                Do
                    rTemp.EntireRow.Delete
                    Set rTemp = ws.Columns(2).FindNext()
                Loop While Not rTemp Is Nothing
            End If
        
        End If
        
    Next ws
    
End Sub

Deze zorgt er dus voor, dat alle rijen op alle tabbladen die overeenkomen met de waarde in de actieve cel worden verwijderd.

Waar ik naar op zoek ben is een code die er voor zorgt, dat alle waarden die niet overeenkomen met de waarde in de actieve cel worden verwijderd (het omgekeerde dus).

Ik zoek nu al twee dagen en heb het nog steeds niet kunnen vinden. Wie kan mij helpen. Alvast bedankt!

 

[HSV]

Zou dit wat voor je zijn?
Uiteraard testen in een testbestand.

Sub hsv()
Dim ws As Worksheet
For Each ws In Sheets
If ws.Index <> ActiveSheet.Index Then
   ws.Range("A1:D100").AutoFilter 2, "<>" & ActiveCell.Value
   ws.AutoFilter.Range.Offset(1).SpecialCells(12).EntireRow.Delete
   ws.Range("A1:D100").AutoFilter
    End If
  Next ws
End Sub

 

[DollyBD]

@HSV: Bedankt voor je reactie. Ik ben een stap verder, echter doet deze nog niet helemaal wat ik wil.

Sub Keuze1_Verwijderen()

Dim ws As Worksheet

For Each ws In Sheets
    
    If ws.Index <> ActiveSheet.Index Then
        On Error Resume Next
        ws.Range("B:B").AutoFilter (2), "<>" & ActiveCell.Value
        ws.AutoFilter.Range.Offset(1).SpecialCells(12).EntireRow.Delete
        ws.Range("B:B").AutoFilter
    End If
  
  Next ws

End Sub

Ik heb de code iets aangepast. Wanneer ik namelijk de code overneem, zoals vermeld krijg ik een foutmelding (1004).
Met de aangepaste code loopt deze wel netjes door, echter het probleem is, dat dan alle rijen verwijderd worden (dus inclusief de rijen die ik graag zou willen laten staan).

Enig idee hoe dit kan?

 

[snb]

Sub M_snb()
   For Each sh In Sheets
    If sh.Index <> ActiveSheet.Index Then
        with sh.usedrange.columns(2)
            .AutoFilter 1, "<>" & ActiveCell.Value
            .Offset(1).SpecialCells(12).EntireRow.Delete
            .AutoFilter
         end with
    End If
  Next
End Sub

 

[DollyBD]

Hoi snb,

Bedankt voor je reactie, echter krijg ik een foutmelding bij het uitvoeren.
De Macro loopt vast op: .AutoFilter 1, "<>" & ActiveCell.Value

Fout 1004 bij uitvoering: Methode Autofilter van Klasse Range mislukt.

Dit was ook het geval in de macro van HSV.

Waar kan dit aan liggen?

 

[snb]

Zit er een of andere beveiliging op dit gebied/werkblad ?
En ik weet natuurlijk ook niet wat de waarde is van de 'activecell'.
Een voorbeeldbestand hier plaatsen is immer het meest efficiënt.

 

[DollyBD]

Hoi snb,

Hierbij het bestand. De data die er in staat is fictief. Bekijk bijlage Testdoc v0.1 - Governance RAID log.xlsm

In een notendop:

Het bestand bestaat uit een x-aantal tabbladen. Alle tabbladen worden geïmporteerd vanaf SharePoint. Deze data kan automatisch worden ververst. Deze wordt dan ook in tabelvorm ingevoegd.
Wat moet het bestand doen.

Op het tabblad menu selecteer ik het overleg waarvan ik het RAID log wil zien. Vervolgens klik ik op de knop bijwerken.
Daarna moet op alle andere tabbladen de rijen worden verwijderd, die niet met het gekozen overleg te maken hebben.

Ik heb jou macro ingevoegd, echter loopt ie tegen een foutmelding aan.

Gr,
DollyBD

 

[snb]

Kijk eens naar de opbouw van de verschillende werkbladen.
De te selecteren tekst staat niet altijd in dezelfde kolom.

Op te lossen met bijv.

Sub Knop1_Klikken()
   On Error Resume Next
   c00 = ActiveCell.Value
   
   For Each sh In Sheets
        If sh.Name <> "Menu" Then
        
        With sh.ListObjects(1).Range
            x = sh.Cells.Find(c00).Column
            If Err.Number = 0 Then
               .AutoFilter x, c00
               .Copy Sheets("Menu").Cells(Rows.Count, 1).End(xlUp).Offset(3)
               .AutoFilter
            End If
            Err.Clear
         End With
    End If
  Next
End Sub

PS. Ik weet niet precies wat je wil, maar het lijkt mij niet verstandig rijen te verwijderen. Kopiëren kan net zo handig zijn.