bij invoer cel andere cel leeg

[wacco]

Hallo,

Momenteel gebruik ik deze code om tussen 2 cellen te toggelen.
Als er een x wordt ingevoerd in de ene cel en er staat een x in de naast gelegen cel, dan wordt deze waarde gewist.
Het gaat daarbij om het bereik BA16:BB686

Code werkt goed, maar als ik een kolom ergens in het sheet toevoeg, dan kan ik in deze toegevoegde kolom niets invoegen of ik krijg de melding dat ik foutief heb ingevoerd en dat de invoer wordt aangepast.
Deze melding is ook niet meer weg te krijgen.
Nogmaals code werkt goed, tot dat ik die kolom invoeg.....hoe dit mogelijk is kan ik niet ontdekken.
Kan iemand eens kijken wat er mis is met dit stukje code.
of eventueel aanpassen

Code is een deel van een grote code welke staat onder : Private Sub Worksheet_Change(ByVal Target As Range)

    'Bij keuze voor jaar overname, kan maar op 1 plaats een x geplaatst worden

    With Target
        If .Count <> 1 Then Exit Sub
        If Not Intersect(.Offset, Range("BA16:BB686")) Is Nothing Then   'Range van plaatsen x
            Application.EnableEvents = False
            If LCase(.Value) = "x" Then .Offset(, IIf(.Column = 53, 1, -1)) = ""    'Als er een x in  de ene kolom wordt geplaatst, wordt andere gewist
            Application.EnableEvents = True
        End If
        'Controleren of x wordt geplaatst bij keuze jaar overzicht
        'Geen x dan wordt deze invoer aangepast

        Dim doel As Range
        Dim cel As Range
    
        Set doel = Range("BA16:BB686")     'Range van x bij jaar overzicht keuze
    
        For Each cel In doel
            If cel = "x" Then
                 ' x is geplaatst, niks doen
            ElseIf cel = vbNullString Then
                'Lege cellen, doe niks
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer"   'alleen x invoer is mogelijk
                cel = "x"
            End If
        Next cel
    End With

 

[emields]

al zo lang lid en toch nog een voorbeeldbestandje vergeten?

 

[wacco]

Voorbeeld bestandje wordt moeilijk, is onderdeel van een groter geheel en niet allemaal toegestaan om te delen.
Helaas......ook ik weet dat dat alles een stuk makkelijke maakt.
Maak hoop toch dat iemand kan ontdekken waar het eventueel aan kan liggen.
De fout melding stuur naar deze code regel :

If Not Intersect(.Offset, Range("BA16:BB686")) Is Nothing Then   'Range van plaatsen x

Ik zal proberen een dummy bestand te maken, zodat er toch een voorbeeld is

 

[emields]

een bestand maken is toch niet zo moeilijk? maar ergens zal er wel iets anders zijn die we zonder bestand niet kunnen zien.

 

[edmoor]

De fout melding stuur naar deze code regel :

If Not Intersect(.Offset, Range("BA16:BB686")) Is Nothing Then   'Range van plaatsen x

Wat is de foutmelding?
En bij welke With hoort die .Offset?
Tevens mis je bij die .Offset de 2 parameters Rij en Kolom.

 

[wacco]

Ik kom er net achter dat ik de vraag voor de wisselwerking van beide cellen eerder op deze site had gesteld, en dat het stukje code ook hier vandaan komt.
Zoals ik al heb vermeld, heeft altijd goed gewerkt.
Maar heb daarna, in de sheet waar het is ingevoegd, nooit meer kolommen ingevoegd, dus ook geen last gehad van dit probleem.
eerdere vraag is gesteld op :
https://www.helpmij.nl/forum/showthread.php/965274-Cel-wissen

@emiels
Dankjewel voor je reactie.
Jouw voorbeeld getest, maar dit is geen toggle functie.
Als in kolom B een x wordt geplaats, moet in de naast gelegen cel van kolom C de aanwezige data gewist worden.
Dit gedeelte werkt.
Maar andersom moet ook werken, invoer in kolom c en naast gelegen cel in kolom B moet gewist worden.
Dat werk nu helaas niet.
Jouw code is ook een stuk eenvoudiger dan de nu gebruikte code, misschien dat de oplossing ligt in het vereenvoudigen??

 

[wacco]

@Edmoor
Foutmelding is het eigenlijk niet, maar krijg een melding van verkeerde invoer welke niet weg te krijgen is.
Stukje code is eerder door jouw gemaakt, ben daar nog steeds blij mee en heeft altijd goed gewerkt.
Alleen bij het invoegen van een kolom gaat het fout.

 

[emields]

dat was toch niet zo moeilijk.

 

[wacco]

Ben nog verder gaan zoeken, en op basis van steeds een stukje uitschakelen, werkt het wel.
Maar waarom het fout gaat.....geen idee.
Ook geen idee hoe dit anders hierin te verwerken.
de 2 stukken welke uitgeschakeld zijn, zijn gemerkt door de tekst 'deze is uitgeschakeld
Beide stukken staan beide vrij ver onderaan.

Private Sub Worksheet_Change(ByVal Target As Range)
     'Met dank aan Ahulpje

'Als een x wordt geplaatst in kolom 17
'Dan worden in kolom 1(A) een 1 geplaatst, als wordt voldaan aan If statement in kolom 1 (A)
'Afhankelijk daarvan worden cellen gekleurd door voorw opmaak en  geselteerde ranges unlockt door VBA
'Als x wordt weggehaald volgt vraag en worden cellen bij keuze Ja leeggemaakt, en kleuren en lijnen verdwijenen en cellen worden gelockt


    Application.ScreenUpdating = False
    If Target.Column = 17 Then                                                  'Kolom waarin x wordt geplaatst
        Unprotect Password:=ww
        Dim Rng As Range
  
        
        For Each Rng In Target
            If Rng = "x" And Rng.Offset(0, -15) = 1 Then                        'Kolom waarin wordt gekeken of x op plaats welke een 1 genereert
                Union(Range(Rng.Offset(0, 1), Rng.Offset(0, 4)), Range(Rng.Offset(0, 21), Rng.Offset(0, 32)), Range(Rng.Offset(0, 36), Rng.Offset(0, 37)), Range(Rng.Offset(0, 41), Rng.Offset(0, 41)), Range(Rng.Offset(0, 43), Rng.Offset(0, 51))).Locked = False 'Cellen welke unlockt worden, gerekend vanaf cel met x (kolom 17)

        
            ElseIf Rng = "x" And Rng.Offset(0, -15) = 0 Then
                                                                                'x geplaatst, verder niets doen
            ElseIf Rng = vbNullString Then
                                                                                'x verwijderd, lege cellen in de selectie overslaan
                If OudeWaarden(Rng.Row, 1) = "x" Then
                    If MsgBox("U staat op het punt om de data van rij " & Rng.Row & " te wissen." _
                    & vbCr & " Weet u zeker dat u dit wilt uitvoeren?" _
                    & vbCr & "Indien u kiest voor JA, dan is dit proces on-omkeerbaar.", vbYesNo + vbCritical + vbDefaultButton2, "Waarschuwing") = vbYes Then 'Waarschuwing voordat daadwerkelijk wordt gewist
                                                                                'Invuldata ook verwijderen
                        With Union(Range(Rng.Offset(0, 1), Rng.Offset(0, 4)), Range(Rng.Offset(0, 21), Rng.Offset(0, 32)), Range(Rng.Offset(0, 36), Rng.Offset(0, 37)), Range(Rng.Offset(0, 41), Rng.Offset(0, 41)), Range(Rng.Offset(0, 43), Rng.Offset(0, 51))) 'cellen welke worden gewist en gelockt
                            .ClearContents
                            .ClearComments
                            Unprotect Password:=ww
                            .Locked = True
                            ActiveSheet.Range("A:A").AutoFilter Field:=1                         'Open uitgebreid overzicht voor data reset
                            ActiveSheet.Range("A:A").AutoFilter Field:=1, Criteria1:="<>"        'Open en toon compact overzicht
                            Blad1.Uitgebreid_Overzicht.Caption = "Uitgebreid overzicht"
                                ActiveSheet.Range("Q16").Select
                                ActiveWindow.ScrollRow = ActiveCell.Row
                        End With
                    Else
                                                                                'x weer terugzetten
                        Rng = "x"
                    End If
                End If
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer1"   'alleen x invoer is mogelijk
                Rng = "x"
            End If
        Next

        Protect Password:=ww

    End If
                   

    'Bij keuze voor jaar overname, kan maar op 1 plaats een x geplaatst worden

    With Target
        If .Count <> 1 Then Exit Sub
        If Not Intersect(.Offset, Range("BA16:BB686")) Is Nothing Then   'Range van plaatsen x
            Application.EnableEvents = False
            If LCase(.Value) = "x" Then .Offset(, IIf(.Column = 53, 1, -1)) = ""    'Als er een x in  de ene kolom wordt geplaatst, wordt andere gewist
            Application.EnableEvents = True
        End If
        
'Deze is uitgeschakeld
        'Controleren of x wordt geplaatst bij keuze jaar overzicht
        'Geen x dan wordt deze invoer aangepast

        'Dim doel As Range
        'Dim cel As Range
    
        'Set doel = Range("BA16:BB686")     'Range van x bij jaar overzicht keuze
    
        'For Each cel In doel
         '   If cel = "x" Then
                 ' x is geplaatst, niks doen
          '  ElseIf cel = vbNullString Then
                'Lege cellen, doe niks
           ' Else
            '    MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer2"   'alleen x invoer is mogelijk
             '   cel = "x"
            'End If
        'Next cel
        
    End With


    'Controleren of x wordt geplaatst bij keuze Vak. en bij Reverse
    'Geen x, dan aanpassing invoer
    Dim cel2 As Range
    For Each cel2 In Range("T16:U686")  'Range van x
        If cel2 = "x" Then
            ' x is geplaatst, niks doen
        ElseIf cel2 = vbNullString Then
            'Lege cellen, doe niks
        Else
            MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer3"   'alleen x invoer is mogelijk
            cel2 = "x"
        End If
    Next cel2
    
'Deze is uitgeschakeld
    'Controleren of x wordt geplaatst bij keuze Grafiek voor bord
    'Geen x, dan aanpassing invoer
    
    'Dim cel3 As Range
    'For Each cel3 In Range("BF16:BF686")  'Range van x
     '   If cel3 = "x" Then
            ' x is geplaatst, niks doen
      '  ElseIf cel3 = vbNullString Then
            'Lege cellen, doe niks
      '  Else
       '     MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer4"   'alleen x invoer is mogelijk
        '    cel3 = "x"
        'End If
    'Next cel3


    Application.ScreenUpdating = True
End Sub

 

[wacco]

Ik hen het e.e.a veranderd en de code van Emiels gebruikt voor de toggle functie, waarvoor dank.
Als er een kolom werdt toegevoegd, kreeg ik de melding van invoer 1, deze blijft in een loop en kwam daar niet meer uit.
Als ik de code bij invoer 1 niet meer actief maakte, en vervolgens een kolom invoeg dan kreeg ik de melding van invoer 5 en ook deze blijft in een loop welke niet beeindigd kon worden.
Als ik ook de code van invoer 5 niet meer actief maakte, kon ik wel een kolom invoegen.

Nu eerst de ranges welke worden gebruikt aangepast, er wordt immers een kolom toegevoegd en ook kolom waarde in code van Emiels aangepast.
Daarna een kolom ingevoegd, en geen probleem deze keer.
Probleem blijkt opgelost te zijn

Onderste deel van (veranderde code) is bijgevoegd

        Dim cl As Range
        Dim rng1 As Range
        Dim rng2 As Range
        Dim rng3 As Range
        Dim rng4 As Range
        Dim rng5 As Range
                
        Set rng1 = Range("BB17:BB686")   'Range van x bij jaar overzicht keuze max
        Set rng2 = Range("BC17:BC686")   'Range van x bij jaar overzicht keuze gemiddeld
        Set rng3 = Range("T17:T686")     'Range van x bij keuze Vak.
        Set rng4 = Range("U17:U686")     'Range van x bij keuze  bij Reverse
        Set rng5 = Range("BG17:BG686")   'Range van x bij keuze Grafiek voor bord
                

         For Each cl In rng1
            If cl = "x" Then
                 ' x is geplaatst, niks doen
            ElseIf cl = vbNullString Then
                'Lege cellen, doe niks
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer1"   'alleen x invoer is mogelijk
                cl = "x"
            End If
         Next cl
         

         For Each cl In rng2
            If cl = "x" Then
                 ' x is geplaatst, niks doen
            ElseIf cl = vbNullString Then
                'Lege cellen, doe niks
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer2"   'alleen x invoer is mogelijk
                cl = "x"
            End If
        Next cl
 
        For Each cl In rng3
            If cl = "x" Then
                 ' x is geplaatst, niks doen
            ElseIf cl = vbNullString Then
                'Lege cellen, doe niks
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer3"   'alleen x invoer is mogelijk
                cl = "x"
            End If
        Next cl

        For Each cl In rng4
            If cl = "x" Then
                 ' x is geplaatst, niks doen
            ElseIf cl = vbNullString Then
                'Lege cellen, doe niks
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer4"   'alleen x invoer is mogelijk
                cl = "x"
            End If
        Next cl


        For Each cl In rng5
            If cl = "x" Then
                 ' x is geplaatst, niks doen
            ElseIf cl = vbNullString Then
                'Lege cellen, doe niks
            Else
                MsgBox "Alleen x toegestaan." & vbCr & "Uw invoer wordt aangepast", vbCritical, "Foutieve invoer5"   'alleen x invoer is mogelijk
                cl = "x"
            End If
        Next cl


'Bij keuze voor jaar overname, kan maar op 1 plaats een x geplaatst worden

    Application.EnableEvents = False 'om niet in een eindeloze loop te geraken
    If Target.Column = 54 And Target.Count = 1 Then Target.Offset(, 1) = IIf(Target.Value = "x", "", "x")
    If Target.Column = 55 And Target.Count = 1 Then Target.Offset(, -1) = IIf(Target.Value = "x", "", "x")
    Application.EnableEvents = True