korte code die niet werkt

[pasan]

met hulp eerder deze avond nog meer code kunnen inkorten maar helaas deze is me niet gelukt

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:=""
    Dim x      As Long
        For i = 1 To 7
        If Me("Ch" & i) Then
           x = cells(Rows.Count, "BL").End(xlUp).Row + 1
            With ActiveSheet
               Range("BL" & x) = (DateValue(Me.Txtdatum))
               If Me.ObBV = True Then
               Range("BM" & x).Value = Txturen & ("B")
               End If
               If Me.ObSnipper = True Then
               Range("BM" & x).Value = Txturen & ("S")
               End If
               If Me.Obziek = True Then
               Range("BM" & x).Value = Txturen & ("Z")
               End If
               Range("BN" & x).Value = Me.TxtOpmerkingen1
               Range("BK" & x).Value = Me.Txtnaam
            End With
        End If
    Next
    
  Unload Me
  ThisWorkbook.Save
ActiveSheet.Protect Password:=""
Application.ScreenUpdating = True
End Sub

 

[Niels28]

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:=""
    Dim x      As Long
        For i = 1 To 7
        If Me("Ch" & i) Then
           x = Cells(Rows.Count, "BL").End(xlUp).Row + 1
            With ActiveSheet
               Range("BL" & x) = (DateValue(Me.Txtdatum)) 'is dit geen  Txtdatum1 geworden?
               If Me.ObBV = True Then Range("BM" & x).Value = me("TxturenB" & i) 'aanelkaar en anders me("Txturen" & B)
               If Me.ObSnipper = True Then Range("BM" & x).Value =me("TxturenS" & i)
               If Me.Obziek = True Then Range("BM" & x).Value = me("TxturenZ" & i)
               Range("BN" & x).Value = Me("TxtOpmerkingen" & i) 'hier ook 1 tm 7?
               Range("BK" & x).Value = Me("Txtnaam" & i) 'hier ook?
            End With
        End If
    Next
Unload Me

Ps waarschijnlijk bedoel je het met de & i achter de Txturen anders krijg je 7x hetzelfde.

Niels

 

[snb]

Private Sub CommandButton1_Click()
 Application.ScreenUpdating = False
 activesheet.Unprotect Password:=""

 with cells(Rows.Count, "BL").End(xlUp).Row
  For i = 1 To 7
   If Me("Ch" & i) Then .offset(i,-1).resize(,4)=array(Txtnaam,DateValue(Txtdatum),txturen & iif(obBv,"B",iif(Obsnipper,"S","Z")),txtOpmerkingen1)
  Next
 end with    

 ActiveSheet.Protect Password:=""
 ThisWorkbook.Save
 Application.ScreenUpdating = True
End Sub

 

[pasan]

heren ontzettend bedankt voor jullie reacties maar helaas wegens familie omstandigheden kon ik niet eerder reageren.
morgen ga ik jullie oplossingen toepassen.
nogmaals bedankt.

 

[pasan]

Niels 28 jou code een gedeelte aangepast maar krijg 1 ding niet voor elkaar
zonder DateValue bij Txtdatum word de datum verkeerd weg geschreven ik moet een datum notatie hebben van dd-mm-jj met jou code krijg ik
dd-m-jj

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:=""
    Dim x      As Long
        For i = 1 To 7
        If Me("Ch" & i) Then
           x = cells(Rows.Count, "BL").End(xlUp).Row + 1
            With ActiveSheet
               Range("BL" & x) = Me("Txtdatum" & i) 'is dit geen  Txtdatum1 geworden? --- JA, MAAR IK MIS DE DATEVALUE BIJ Txtdatum
               If Me.ObBV = True Then Range("BM" & x).Value = Me("Txturen" & i) & "B"      '---aangepast
               If Me.ObSnipper = True Then Range("BM" & x).Value = Me("Txturen" & i) & "S"
               If Me.Obziek = True Then Range("BM" & x).Value = Me("Txturen" & i) & "Z"
               Range("BN" & x).Value = Me("TxtOpmerkingen" & i) 'hier ook 1 tm 7? -----JA
               Range("BK" & x).Value = Txtnaam 'hier ook?---- NEE
            End With
        End If
    Next
Unload Me
  ThisWorkbook.Save
ActiveSheet.Protect Password:=""
Application.ScreenUpdating = True
End Sub

 

[pasan]

snb jou code kreeg ik niet werkend zoals die nu is, en omdat de code mijn pet net te boven gaat ben ik er niet verder mee gegaan.
maar uiteraard bedankt voor je bijdrage

 

[pasan]

inmiddels opgelost doormiddel van volgende matrixformule

=ALS.FOUT(INDEX($BM$2:$BM2000;VERGELIJKEN(1;($BK$2:$BK2000=$AC$1)*(DATUMWAARDE($BL$2:$BL2000)=G4);0));"")

door DATUMWAARDE bij in de formule te plaatsen worden de juiste waarden weer gevonden in kolom BL

 

[Niels28]

@Pasan

Ik had die datevalue toch ook niet weggehaald?
maar met datevalue is ie zo:

DateValue(Me("Txtdatum" & i))

Niels

 

[pasan]

het opzoeken met de matrixformule is dan wel opgelost
maar het verwijderen gaat nog steeds niet goed omdat de datum formaat op bv 1-1-2012 staat als de datum 1-01-2012 zou zijn dan werkt het verwijderen wel

 

[pasan]

Niels 28 dat was hm helemaal :thumb:
zover werkt het nu met korte codes bedankt voor je hulp

 

[pasan]

ondaks dat ik hm al op opgelost heb gezet moet er nog wel een excuus af
ik heb dus zelf de DateValue verwijdert zoals je zelf al aangaf Niels 28 tenminste als ik naar de code van jou en mijzelf hierboven kijk.
helaas heb ik het niet gezien (hoe stom ken je zijn)
niels nogmaals mijn excuses je had het meteen al goed

 

[Niels28]

Excuses aanvaard
Hebben we allemaal wel eens last van, snapte
er in eerste instantie al niks van dat het niet werkte.

Niels