kan deze code korter?

[pasan]

Hallo
op een userform heb ik 7 textboxen staan met daarin een datum
ernaast staan 7 checkboxen, als ik er 1 of alle 7 selecteer worden de datums opgezocht in een kolom en verwijdert
Maar ik heb er weer eens een hele lange code van gemaakt omdat het mij nog steeds niet lukt om zoiets kort en bondig neer te zetten
Iemand tijd?

Private Sub Cbogegevensverwijderen_Click()
ActiveSheet.Unprotect Password:=""
Application.ScreenUpdating = False
    
    Dim FindString As Date
    Dim Rng As Range
    If Ch1 = True Then
    FindString = Txtdatum
    With ActiveSheet.Range("BL:BL")
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
       End If
     End If
     
    If Ch2 = True Then
    FindString = Txtdatum2
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
        End If
     End If

    If Ch3 = True Then
    FindString = Txtdatum3
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
        End If
     End If

    If Ch4 = True Then
    FindString = Txtdatum4
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
        End If
     End If
     
    If Ch5 = True Then
    FindString = Txtdatum5
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
        End If
     End If
     
    If Ch6 = True Then
    FindString = Txtdatum6
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
        End If
     End If
     
     If Ch7 = True Then
     FindString = Txtdatum7
        Set Rng = .Find(What:=FindString, _
                        after:=.cells(.cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            Application.Goto Rng, False
            ActiveCell.Delete Shift:=xlUp
            ActiveCell.Offset(0, -1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 1).Delete Shift:=xlUp
            ActiveCell.Offset(0, 2).Delete Shift:=xlUp
        End If
     End If
    
    End With
Unload Me
ThisWorkbook.Save
Application.ScreenUpdating = True
ActiveSheet.Protect Password:=""
End Sub

 

[Warme bakkertje]

Private Sub Cbogegevensverwijderen_Click()
ActiveSheet.Unprotect Password:=""
Application.ScreenUpdating = False
    
    Dim FindString As Date
    Dim Rng As Range
    For i = 1 To 7
        If Me("Ch" & i) Then
            FindString = Me("Txtdatum" & i)
            With ActiveSheet.Range("BL:BL")
                Set Rng = .Find(What:=FindString, _
                        after:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                    If Not Rng Is Nothing Then
                        Application.Goto Rng, False
                        ActiveCell.Delete Shift:=xlUp
                        ActiveCell.Offset(0, -1).Delete Shift:=xlUp
                        ActiveCell.Offset(0, 1).Delete Shift:=xlUp
                        ActiveCell.Offset(0, 2).Delete Shift:=xlUp
                    End If
            End With
        End If
    Next
Unload Me
ThisWorkbook.Save
Application.ScreenUpdating = True
ActiveSheet.Protect Password:=""
End Sub

Je moet nog wel je eerste datumveld Txtdatum1 benoemen om het te laten werken.

 

[Niels28]

Je moet wel Txtdatum verander in Txtdatum1

Private Sub Cbogegevensverwijderen_Click()
ActiveSheet.Unprotect Password:=""
Application.ScreenUpdating = False
With ActiveSheet.Range("BL:BL")

     For i = 1 To 7
    If Controls("Ch" & i) = True Then
    FindString = Controls("Txtdatum" & i)
        Set Rng = .Find(What:=FindString, _
                        after:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then Rng.Offset(0, -1).Resize(1, 4).Delete Shift:=xlUp
     End If
     Next
    End With
Unload Me
ThisWorkbook.Save
Application.ScreenUpdating = True
ActiveSheet.Protect Password:=""
End Sub

Te laat...... antwoord staat er al

Niels

 

[pasan]

Warmebakkertje het klopt helemaal dank je wel :thumb:
Ook Niels bedankt voor je inzet