Thema: Schleife für Zelleninhalt-Prüfung | Herbers Excel-Forum

Moin Excellianer!
Nach langer Zeit benötige ich wieder mal Eure Hilfe. Auch finde ich nix entsprechendes im Archiv (...aber vielleicht stelle ich ja die Fragen falsch...).
Ich habe zu diesem Zweck eine Beispielmappe hochgeladen. In dieser steht auch meine Fragestellung:
https://www.herber.de/bbs/user/65918.xls
In den roten Zellen darf erst ein Eintrag erfolgen, wenn in den jeweils darüber liegenden gelben Zellen ein Eintrag vorhanden ist. Allen farbig markierten Zellen sind per "Daten" > "Gültigkeit" eine Namensliste zugeordnet. Diese befindet sich in der Tabelle2. Mit einem kleinen VBA-Skribt ist mir das für die Zelle B12 gelungen... ....wenns auch nur zur Zelle B10 zurück geht... ...und leider auch keine wiederholte Prüfung stattfindet, wenn nachträglich der Name aus B10 gelöscht wird...
Mein Schmalspur-VBA setzt mir wieder mal Grenzen! Vielen Dank für Eure Hilfe!!
Viele Grüße aus dem hohen Norden!
Lenni

Hallo,
versuche es mal so.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Intersect(Range("B12,E12,H12,B15,E15,H15,B18,E18,H18,B21,E21,H21"), Target)
If Not Bereich Is Nothing Then
Application.EnableEvents = False
For Each Bereich In Bereich.Areas
If Bereich.Offset(-2, 0) = "" Or Bereich.Offset(-1, 0) = "" Then
Bereich.Value = ""
End If
Next Bereich
Application.EnableEvents = True
End If
End Sub

Gruß Tino

Hallo Tino!!!
Danke für Deine Antwort!! ...ich verstehe den Grundansatz!! Leider ist es nicht ganz so, wie ich es mir vorstelle und ich versuche nun Deinen Vorschlag mit meinem VBA "abzugleichen"... ...was soll ich sagen: Ich gehe lieber wieder ins Forum.
Wo habe ich noch Schwierigkeiten?: Ich bleibe mal bei Zelle B12. Steht in den Zellen B10:B11 nix drinne, dann darf auch kein Eintrag in B12 erfolgen und B12 wird gelöscht. ABER DANN soll es ja zur jeweils leeren Zelle B10 und/oder B11 zurück gehen, damit hier zunächst ein Eintrag per Dropdown erfolgt.
Weiter findet leider auch keine Prüfung in B12 statt, wenn nachträglich aus B10 oder B11 gelöscht wird.
UND natürlich soll dass denn bei allen anderen farbigen Bereichen dementsprechend funktionieren.
Hast Du noch Ideen?! Vielen Dank!!
Gruß
Lenni

Hallo,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim BereichRot As Range, BereichGelb As Range

 Set BereichRot = Intersect(Range("B12,E12,H12,B15,E15,H15,B18,E18,H18,B21,E21,H21"), Target)
 Set BereichGelb = Intersect(Range("B10:B11,E10:E11,H10:H11,H13:H14,E13:E14,B13:B14,B16:B17,E16:E17,H16:H17,H19:H20,E19:E20,B19:B20"), Target)
 
 If Not BereichGelb Is Nothing Or Not BereichRot Is Nothing Then
  Application.EnableEvents = False
 
 
 If Not BereichGelb Is Nothing Then
  
    For Each BereichGelb In BereichGelb.Areas
     If BereichGelb(1, 1).Offset(2, 1).Value <> "" Then
        If BereichGelb(1, 1) = "" Or BereichGelb(2, 1) = "" Then
            BereichGelb(1, 1).Offset(2, 1).Value = ""
        End If
     End If
    Next BereichGelb

 End If
 
 If Not BereichRot Is Nothing Then
     For Each BereichRot In BereichRot.Areas
       If BereichRot <> "" Then
            If BereichRot.Offset(-2, 0) = "" Or BereichRot.Offset(-1, 0) = "" Then
                BereichRot.Value = ""
                If BereichRot.Offset(-1, 0) = "" Then
                  BereichRot.Offset(-1, 0).Select
                ElseIf BereichRot.Offset(-2, 0) = "" Then
                  BereichRot.Offset(-2, 0).Select
                End If
            End If
       End If
     Next BereichRot
 End If

 
 Application.EnableEvents = True
End If
End Sub

Gruß Tino

Hallo,
falscher Offset.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim BereichRot As Range, BereichGelb As Range

 Set BereichRot = Intersect(Range("B12,E12,H12,B15,E15,H15,B18,E18,H18,B21,E21,H21"), Target)
 Set BereichGelb = Intersect(Range("B10:B11,E10:E11,H10:H11,H13:H14,E13:E14,B13:B14,B16:B17,E16:E17,H16:H17,H19:H20,E19:E20,B19:B20"), Target)
 
 If Not BereichGelb Is Nothing Or Not BereichRot Is Nothing Then
  Application.EnableEvents = False
 
 
 If Not BereichGelb Is Nothing Then
  
    For Each BereichGelb In BereichGelb.Areas
     If BereichGelb(1, 1).Offset(2, 0).Value <> "" Then
        If BereichGelb(1, 1) = "" Or BereichGelb(2, 1) = "" Then
            BereichGelb(1, 1).Offset(2, 0).Value = ""
        End If
     End If
    Next BereichGelb

 End If
 
 If Not BereichRot Is Nothing Then
     For Each BereichRot In BereichRot.Areas
       If BereichRot <> "" Then
            If BereichRot.Offset(-2, 0) = "" Or BereichRot.Offset(-1, 0) = "" Then
                BereichRot.Value = ""
                If BereichRot.Offset(-1, 0) = "" Then
                  BereichRot.Offset(-1, 0).Select
                ElseIf BereichRot.Offset(-2, 0) = "" Then
                  BereichRot.Offset(-2, 0).Select
                End If
            End If
       End If
     Next BereichRot
 End If

 
 Application.EnableEvents = True
End If
End Sub
       

Gruß Tino

Danke Tino!! ...es funktioniert tadellos!! ...mit einer kleinen Einschränkung: Löscht man nachträglich aus den gleben Zellen, erfolgt keine erneute Prüfung und Rücksetzung in die soeben gelöschte Zelle. Ist aber das kleinste Übel und damit kann ich leben!!
Nochmals vielen Dank! ...ich habe wieder etwas zum nachdenken* und Da hast mir wiederholt sehr geholfen!!
Gruß
Lenni
*...vielleicht kriege das mit dem nachträglichen löschen noch selber hin...

Hallo,
mach die Zeile

If BereichGelb(1, 1).Offset(2, 0).Value <> "" Then

und die dazugehörige End IF.
raus
Also so

'...
If Not BereichGelb Is Nothing Then
For Each BereichGelb In BereichGelb.Areas
If BereichGelb(1, 1) = "" Or BereichGelb(2, 1) = "" Then
BereichGelb(1, 1).Offset(2, 0).Value = ""
End If
Next BereichGelb
End If
'...

Gruß Tino

Nochmals herzlichen Dank Tino!! Das "läuft rund"!!
Gruß
Lenni