• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Twee maal Worksheet_Change Event

Status
Niet open voor verdere reacties.
B

Bandito

Gebruiker
Lid geworden
8 okt 2012
Berichten
201
Hallo,

Nu heb ik twee werkende codes gekregen met veel hulp uit deze forums, hartelijk dank!
Nu wil ik ze gaan toepassen bots ik tegen het volgende:

Compileerfout: er is een dubbelzinnige naam gevonden: WorkSheet_Change

Het gaat om de volgende codes:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rGewensteFilters As Range, rFilter As Range
Dim i As Integer, iKolom As Integer, iRij As Integer
Set rGewensteFilters = Range("A6:S6")                                               
Set rFilter = Range("A8")                                                             
If Not Intersect(Target, rGewensteFilters) Is Nothing Then 
    iKolom = rGewensteFilters.Columns.Count                                          
    iRij = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    ActiveSheet.AutoFilterMode = False                                                 
    With rFilter.Resize(iRij - 8, iKolom)                                                
        For i = 1 To iKolom                                                                  
            If Not IsEmpty(rFilter.Offset(-2, i - 1)) Then                                      
                If IsNumeric(rFilter.Offset(-2, i - 1)) Then                                       
                    .AutoFilter Field:=i, Criteria1:="=" & rFilter.Offset(-2, i - 1).Value 
                ElseIf IsDate(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Operator:=xlFilterValues, Criteria2:=Array(2, Format(rFilter.Offset(-2, i - 1).Value, "mm/dd/yyyy"))
                Else                                                                               
                    .AutoFilter Field:=i, Criteria1:="=" & "*" & rFilter.Offset(-2, i - 1).Value & "*" 
                End If
            End If
        Next
    End With
End If
End Sub

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("Q8:Q31")) Is Nothing Then Exit Sub
ActiveSheet.Unprotect Password:=1234
Dim cl As Range
On Error GoTo oeps

 For Each cl In Range("Q8:Q31")

    cl.Offset(, -6).Locked = cl <> ""
    cl.Offset(, -4).Locked = cl <> ""

    cl.Offset(, -5).Locked = True
    cl.Offset(, -3).Resize(, 3).Locked = True

 Next
oeps:
 ActiveSheet.Protect Password:=1234
End Sub

Nu heb ik al op internet gezocht hoe ik dit kon oplossen maar de antwoorden daarop maken mij nog niet alles duidelijk. Ze hebben het over een algemene module en modelus in een werkblad?

Met vriendelijke groet,
 
Subroutines en functies mogen niet dubbel voor komen.
In dit geval heten ze allebei Worksheet_Change.
Je zult ze moeten combineren.
 
Laatst bewerkt:
Deze zou kunnen werken op voorwaarde dat die eerste code correct werkt zoals ze hier staat:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("Q8:Q31")) Is Nothing Then GoTo Volgende
ActiveSheet.Unprotect Password:=1234
Dim cl As Range
On Error GoTo oeps

 For Each cl In Range("Q8:Q31")

    cl.Offset(, -6).Locked = cl <> ""
    cl.Offset(, -4).Locked = cl <> ""

    cl.Offset(, -5).Locked = True
    cl.Offset(, -3).Resize(, 3).Locked = True

 Next
oeps:
 ActiveSheet.Protect Password:=1234
Exit Sub
Volgende:
Dim rGewensteFilters As Range, rFilter As Range
Dim i As Integer, iKolom As Integer, iRij As Integer
Set rGewensteFilters = Range("A6:S6")
Set rFilter = Range("A8")
If Not Intersect(Target, rGewensteFilters) Is Nothing Then
    iKolom = rGewensteFilters.Columns.Count
    iRij = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    ActiveSheet.AutoFilterMode = False
    With rFilter.Resize(iRij - 8, iKolom)
        For i = 1 To iKolom
            If Not IsEmpty(rFilter.Offset(-2, i - 1)) Then
                If IsNumeric(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Criteria1:="=" & rFilter.Offset(-2, i - 1).Value
                ElseIf IsDate(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Operator:=xlFilterValues, Criteria2:=Array(2, Format(rFilter.Offset(-2, i - 1).Value, "mm/dd/yyyy"))
                Else
                    .AutoFilter Field:=i, Criteria1:="=" & "*" & rFilter.Offset(-2, i - 1).Value & "*"
                End If
            End If
        Next
    End With
End If
End Sub
 
Hallo,

Excuses voor mijn late reactie maar de laatste dagen waren nogal hectisch.

Helaas werkt het niet, de twee codes botsen.

Zoals je misschien herinnerd cobbe is de eerste code voor het automatisch blokkeren en deblokkeren van cellen.
De tweede code is om de gegevens te filteren.

Wanneer ik de gegevens wil filteren krijg ik deze melding: Deze opdracht kan niet uitgevoerd worden op een beveiligd blad. en dan nog heel wat tekst.

Is hier omheen te werken?
Ik heb al geprobeerd om
Code: 
ActiveSheet.Unprotect Password:=1234
op andere plekken te plakken maar niet met het gewenste resultaat.

Met vriendelijke groet,
 
Ja die beveiliging moest natuurlijk naar het einde van de code verschuiven:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("Q8:Q31")) Is Nothing Then GoTo Volgende
ActiveSheet.Unprotect Password:=1234
Dim cl As Range
On Error GoTo oeps

 For Each cl In Range("Q8:Q31")

    cl.Offset(, -6).Locked = cl <> ""
    cl.Offset(, -4).Locked = cl <> ""

    cl.Offset(, -5).Locked = True
    cl.Offset(, -3).Resize(, 3).Locked = True
 Next
Exit Sub
Volgende:
Dim rGewensteFilters As Range, rFilter As Range
Dim i As Integer, iKolom As Integer, iRij As Integer
Set rGewensteFilters = Range("A6:S6")
Set rFilter = Range("A8")
If Not Intersect(Target, rGewensteFilters) Is Nothing Then
    iKolom = rGewensteFilters.Columns.Count
    iRij = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    ActiveSheet.AutoFilterMode = False
    With rFilter.Resize(iRij - 8, iKolom)
        For i = 1 To iKolom
            If Not IsEmpty(rFilter.Offset(-2, i - 1)) Then
                If IsNumeric(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Criteria1:="=" & rFilter.Offset(-2, i - 1).Value
                ElseIf IsDate(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Operator:=xlFilterValues, Criteria2:=Array(2, Format(rFilter.Offset(-2, i - 1).Value, "mm/dd/yyyy"))
                Else
                    .AutoFilter Field:=i, Criteria1:="=" & "*" & rFilter.Offset(-2, i - 1).Value & "*"
                End If
            End If
        Next
    End With
End If
oeps:
 ActiveSheet.Protect Password:=1234
End Sub
 
Ik denk dat ie zo lukt:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
ActiveSheet.Unprotect Password:=1234
'Deze code werkt enkel als er een wijziging is in bereik S9:S31
If Intersect(Target, Range("S9:S31")) Is Nothing Then GoTo Volgende
' Haal eerst de beveiliging van het werkblad af.
 
 Dim cl As Range
'Als er een foutje zou optreden netjes afsluiten.
On Error GoTo oeps
'Loop het hele bereik S9:S31 door.
 For Each cl In Range("S9:S31")
' (De)Blokkeer de cellen met de gegevens : nummer en omschrijving indien er een paraaf komt of niet.
    cl.Offset(, -18).Locked = cl <> ""
    cl.Offset(, -10).Locked = cl <> ""
    cl.Offset(, -9).Locked = cl <> ""
    cl.Offset(, -8).Locked = cl <> ""
    cl.Offset(, -7).Locked = cl <> ""
    cl.Offset(, -3).Locked = cl <> ""
    cl.Offset(, -2).Locked = cl <> ""
    cl.Offset(, -1).Locked = cl <> ""
'Bij deblokkering toch de cellen met omschrijving blokkeren.
    cl.Offset(, -17).Locked = True
    cl.Offset(, -12).Locked = True
    cl.Offset(, -11).Locked = True
    cl.Offset(, -6).Locked = True
    'cl.Offset(, -3).Resize(, 3).Locked = True
'Volgende cel.
 Next
'Beveiligen en Afsluiten.
Application.EnableEvents = True
Exit Sub
Volgende:
Dim rGewensteFilters As Range, rFilter As Range
Dim i As Integer, iKolom As Integer, iRij As Integer
Set rGewensteFilters = Range("A8:S8")
Set rFilter = Range("A8")
If Not Intersect(Target, rGewensteFilters) Is Nothing Then
    iKolom = rGewensteFilters.Columns.Count
    iRij = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    ActiveSheet.AutoFilterMode = False
    With rFilter.Resize(iRij - 8, iKolom)
        For i = 1 To iKolom
            If Not IsEmpty(rFilter.Offset(-2, i - 1)) Then
                If IsNumeric(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Criteria1:="=" & rFilter.Offset(-2, i - 1).Value
                ElseIf IsDate(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Operator:=xlFilterValues, Criteria2:=Array(2, Format(rFilter.Offset(-2, i - 1).Value, "mm/dd/yyyy"))
                Else
                    .AutoFilter Field:=i, Criteria1:="=" & "*" & rFilter.Offset(-2, i - 1).Value & "*"
                End If
            End If
        Next
    End With
End If
oeps:
 Application.EnableEvents = True
 ActiveSheet.Protect Password:=1234
End Sub
 
Hallo Cobbe,

Helaas het wil nog niet werken.

De celblokkade blijkt niet meer te werken wanneer ik deze code gebruik. De filter werkt nu wel.
Wanneer ik nu een paraaf invoer in de eerste regel lijkt het te werken, maar wanneer ik precies hetzelfde doe in regel twee springen de cellen niet op blokkeren. Alleen de eerste invoer regel werkt dus eigenlijk maar.

Om het zelf te testen:Bekijk bijlage InpakV1.0.xlsm
 
Het werkt niet door het gebruik van die (vervloekte) samengevoegde cellen.

Waarom wil iedereen toch die samengevoegde cellen gebruiken terwijl je een kolom zo breed kan maken als je wil, of de inhoud verdelen over verschillende cellen?
 
Laatst bewerkt:
Standaard voorbeeldje waarom helpers aangeven om geen samengevoegde cellen icm met VBA te gebruiken....;)
 
Hallo,

Ik heb de (vervloekte) samengevoegde cellen eruit gehaald. Ik heb het een en ander aangepast maar helaas het wil nog niet werken.

De cellen die geblokkeerd moeten worden, worden niet geblokkeerd. En de cellen die altijd geblokkeerd moeten blijven raken juist gedeblokkeerd als ik een paraaf zet.
Wanneer ik een paraaf zet raakt heel het blad gedeblokkeerd.

Ik heb niets ingrijpends in de code veranderd dus ik snap niet hoe dit ineens gebeurt. Ik heb de code een aantal keer doorgelezen wat ik heb veranderd maar kan het niet vinden..
Mijn excuses als ik iets "simpels" over het hoofd zie.

Bekijk bijlage InpakV1.1.xlsm
 
Laatst bewerkt:
Hey,

Het werkt als een zonnetje! Wederom erg bedankt!

Nu durft ik het bijna niet te zeggen, maar ik begon dit topic om erachter te komen hoe ik meerdere change events kon gebruiken. Ik snap hoe dit is gedaan met twee change events maar ik wil nu een korte derde erbij doen maar tot nog toe zonder succes.

Het automatisch opslaan als er iets wordt veranderd in de kolom paragraaf:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("M8:M100")) Is Nothing Then
        ThisWorkbook.Save
    End If
End Sub

Heb geprobeerd om deze op verschillende plaatsen ertussen te plakken maar helaas wil hij dan niet werken.
Dit is het laatste stukje en dan zou hij af moeten zijn!

Met vriendelijke groet,
 
Die moet je me toch eens uitleggen.
Is het de bedoeling dat als je in het bereik M8:M100 klikt dat uw bestand opgeslagen wordt?
Heb het geprobeerd:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
[B][/B][COLOR="#FF0000"]If Intersect(Target, Range("A6:M6,M9:M100")) Is Nothing Then Exit Sub[/COLOR]
Application.EnableEvents = False
ActiveSheet.Unprotect Password:=1234
'Deze code werkt enkel als er een wijziging is in bereik M9:M31
If Intersect(Target, Range("M9:M100")) Is Nothing Then GoTo Volgende
Dim cl As Range
'Als er een foutje zou optreden netjes afsluiten.
On Error GoTo oeps
'Loop het hele bereik M9:M31 door.
 For Each cl In Range("M9:M100")
' (De)Blokkeer de cellen met de gegevens : nummer en omschrijving indien er een paraaf komt of niet.
    cl.Offset(, -12).Locked = cl <> ""
    cl.Offset(, -8).Locked = cl <> ""
    cl.Offset(, -7).Locked = cl <> ""
    cl.Offset(, -6).Locked = cl <> ""
    cl.Offset(, -5).Locked = cl <> ""
    cl.Offset(, -3).Locked = cl <> ""
    cl.Offset(, -2).Locked = cl <> ""
    cl.Offset(, -1).Locked = cl <> ""
'Bij deblokkering toch de cellen met omschrijving blokkeren.
    cl.Offset(, -11).Locked = True
    cl.Offset(, -10).Locked = True
    cl.Offset(, -9).Locked = True
    cl.Offset(, -4).Locked = True
    'cl.Offset(, -3).Resize(, 3).Locked = True
'Volgende cel.
 Next
    Application.EnableEvents = True
   [B][/B][COLOR="#FF0000"] ActiveSheet.Protect Password:=1234
    Application.DisplayAlerts = False
    ThisWorkbook.Save[/COLOR]
GoTo oeps
Volgende:
Dim rGewensteFilters As Range, rFilter As Range
Dim i As Integer, iKolom As Integer, iRij As Integer
Set rGewensteFilters = Range("A6:M6")
Set rFilter = Range("A6")
If Not Intersect(Target, rGewensteFilters) Is Nothing Then
    iKolom = rGewensteFilters.Columns.Count
    iRij = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    ActiveSheet.AutoFilterMode = False
    With rFilter.Resize(iRij - 8, iKolom)
        For i = 1 To iKolom
            If Not IsEmpty(rFilter.Offset(-2, i - 1)) Then
                If IsNumeric(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Criteria1:="=" & rFilter.Offset(-2, i - 1).Value
                ElseIf IsDate(rFilter.Offset(-2, i - 1)) Then
                    .AutoFilter Field:=i, Operator:=xlFilterValues, Criteria2:=Array(2, Format(rFilter.Offset(-2, i - 1).Value, "mm/dd/yyyy"))
                Else
                    .AutoFilter Field:=i, Criteria1:="=" & "*" & rFilter.Offset(-2, i - 1).Value & "*"
                End If
            End If
        Next
    End With
End If
oeps:
 Application.EnableEvents = True
 ActiveSheet.Protect Password:=1234
End Sub

De rode code zou dit moeten doen. De eerste regel (intersect....) dient om het bereik af te bakenen waarin deze code actief wordt.
 
Laatst bewerkt:
Het bestand is een registratiebestand. Het idee is dus dat mensen daar de gehele dag gegevens invoeren. Nu weet ik dat excel een melding geeft als je afsluit zonder op te slaan.

Om er nu voor te zorgen dat niet een gehele dag aan registraties verloren gaat wanneer mensen op dat kruisje drukken, en per ongeluk of uit onzekerheid op nee drukken bij opslaan, leek het mij een goed idee om het bestand zichzelf te laten opslaan als er iets in de kolom paraaf veranderd.

Dus mensen voeren iets in zetten een paraaf - bestand wordt opgeslagen.

Mensen veranderen een rij en halen dus een paraaf weg om dit te kunnen doen - bestand wordt opgeslagen.
 
Verdiep je eens in Userforms en waarom die zo heten.
 
Beste Snb,

Dit is mij al vaker gezegt. Helaas zijn de mensen waarvoor ik dit maak bang voor dingen die ze niet kunnen zien of begrijpen.

Het moet er dus zo uitzien zoals ze gewent zijn etc. Vandaar dat ik niet met userforms kan en mag werken. Wie weet kan ik in de toekomst dit veranderen naar een userform maar dat zit er nu nog niet in.
 
Het werkt perfect!

Wederom hartelijk dank voor je tijd en geduld.

Met vriendelijke groet,
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan