Regels verwijderen VBA

[Severance1]

Hallo allemaal,

Ik heb een probleem met het verwijderen van regels doormiddel van een macro.
Ik heb een lijst met projecten de lijst is van regel 15 tot 1000.
Bij die projecten geef je een datum in kolom G (een zogenaamde indien datum). Voor het opschonen van de lijst zou ik graag een knop willen maken en dat de knop dan een macro gaat uitvoeren. Alle projecten voor de ingegeven datum in D2 worden verwijderd.

Zelf had ik dit geprobeerd.

Sub test()
    Dim sDatum As String

    sDatum = Sheets("Indienen").[D2]
    CVDate([D2]) = x
    For Each c In Sheets("Indienen").[G15:G1000]
    On Error Resume Next
        If c < UCase(x) Then
            c.Rows.EntireRow.Delete
        End If
    Next
End Sub

Heeft iemand enig idee wat ik hier fout doe.
Bij voorbaat dank.

Groeten,

Boudewijn

 

[Wigi]

Je maakt een lus doorheen een bereik, en verwijdert regels.

Ben je zeker dat je van onder naar boven door het bereik loopt? Want als je pakweg rij 100 verwijdert, wordt rij 101 de nieuwe rij 100 en sla je de vroegere rij 101 dus over.

 

[Severance1]

Je maakt een lus doorheen een bereik, en verwijdert regels.

Ben je zeker dat je van onder naar boven door het bereik loopt? Want als je pakweg rij 100 verwijdert, wordt rij 101 de nieuwe rij 100 en sla je de vroegere rij 101 dus over.

Eigelijk moet dat dus net andersom. Maar mijn kennis van VBA schiet te kort denk ik.

Ik heb een voorbeeld bestandje bijgevoegd dan kun je het princiepe zien.

Groeten,

Boudewijn

 

[Warme bakkertje]

Test deze eens uit op een kopie van je bestand

Sub tst2()
Application.EnableEvents = False
With Sheets("Indienen")
    .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row).Value = "*"
For Each cl In .Range("G15:G" & .Cells(Rows.Count, 1).End(xlUp).Row)
    If cl.Value < Date Then cl.Offset(, 11).ClearContents
Next
With .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .SpecialCells(4).EntireRow.Delete
        .Clear
End With
End With
Application.EnableEvents = True
End Sub

 

[Severance1]

Test deze eens uit op een kopie van je bestand

Sub tst2()
Application.EnableEvents = False
With Sheets("Indienen")
    .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row).Value = "*"
For Each cl In .Range("G15:G" & .Cells(Rows.Count, 1).End(xlUp).Row)
    If cl.Value < Date Then cl.Offset(, 11).ClearContents
Next
With .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .SpecialCells(4).EntireRow.Delete
        .Clear
End With
End With
Application.EnableEvents = True
End Sub

Dit is wat ik er van gemaakt heb alleen als een blad nou leeg is dan geeft hij een fout melding. Dat is ook logisch want in een lege cel zit geen datum en niks met een datum vergelijken kan niet dacht ik zo.

Heb je enig idee hoe ik dit kan omzeilen dat wanneer in de range geen datums voorkomen hij geen fout melding geeft.

Het gaat om dit stukje:

For Each cl In .Range("G15:G" & .Cells(Rows.Count, 1).End(xlUp).Row)
        If CDate(cl.Value) < CDate(sOpschoondatum) Then
            cl.Offset(, 11).ClearContents
            bRegelsGevonden = True
        End If
    Next

Dim sOpschoondatum As String
Dim bRegelsGevonden As Boolean

Application.EnableEvents = False
bRegelsGevonden = False

sOpschoondatum = Sheets("Indienen").Cells(4, 4).Value

With Sheets("Indienen")
    'Markeer in eerste instantie alle cellen voor verwijderen met *
    .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row).Value = "*"
    
    'Verwijder * voor de regels met een datum < referentiedatum
    For Each cl In .Range("G15:G" & .Cells(Rows.Count, 1).End(xlUp).Row)
        If CDate(cl.Value) < CDate(sOpschoondatum) Then
            cl.Offset(, 11).ClearContents
            bRegelsGevonden = True
        End If
    Next
    
    'Verwijder alle regels die geen * markering meer hebben
    If bRegelsGevonden = True Then
        With .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row)
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With
    End If
        
    'Verwijder de resterende * markeringen
    With .Range("R15:R" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .Clear
    End With
    
End With

Application.ScreenUpdating = False

Groeten,

Boudewijn

 

[Warme bakkertje]

Bovenaan je code

On error resume next

 

[Severance1]

Bovenaan je code

On error resume next

Dank je het is opgelost

Groeten,

Boudewijn

 

[snb]

of

Sub tst2()
  With Sheets("Indienen").usedrange.offset(14).columns(18)
     .autofilter 1, "=<" & format(date,"mm/dd/yyyy")
     .offset(1).SpecialCells(xlcelltypevisible).EntireRow.Delete
     .autofilter
  End With
End Sub