Wenn Spalte A leer, dann... (VBA)

Dim rngZelle As Range If Not Intersect(Target, Range("A9:A36")) Is Nothing Then If Target.Cells(1) = "" Then For Each rngZelle In Intersect(Target, Range("A9:A36")) Union(Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 6)), Cells(rngZelle.Row, 7), Cells(rngZelle.Row, 8), Cells(rngZelle.Row, 9), Cells(rngZelle.Row, 11), Cells(rngZelle.Row, 12)).Value = "¨" Next rngZelle End If End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rngZelle As Range If Not Intersect(Target, Range("A9:A36")) Is Nothing Then If Target.Cells(1) = "" Then For Each rngZelle In Intersect(Target, Range("A9:A36")) Union(Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 6)), Cells(rngZelle.Row, 7), Cells(rngZelle.Row, 8), Cells(rngZelle.Row, 9), Cells(rngZelle.Row, 11), Cells(rngZelle.Row, 12)).Value = "¨" Next rngZelle End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngZelle As Range If Not Intersect(Target, Range("A9:A36")) Is Nothing Then If Target.Cells(1) = "" Then For Each rngZelle In Intersect(Target, Range("A9:A36")) Cells(rngZelle.Row, 5).Resize(, 1, 8).Value = "¨" Cells(rngZelle.Row, 4).ClearContents Cells(rngZelle.Row, 13).ClearContents Next rngZelle End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Set rngBereich = Range("A9:A36,A41:A67") If Not Intersect(Target, Bereich) Is Nothing Then If Target.Cells(1) = "" Then Application.EnableEvents = False With Intersect(rngBereich, Target) Intersect(.EntireRow, Range("D:D,M:M")).ClearContents Intersect(.EntireRow, Range("E:I",K:L")).Value = "¨" End with Application.EnableEvents = True End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Set rngBereich = Range("A9:A36,A41:A67") If Not Intersect(Target, rngBereich) Is Nothing Then 'hier If Target.Cells(1) = "" Then Application.EnableEvents = False With Intersect(rngBereich, Target) Intersect(.EntireRow, Range("D:D")).ClearContents 'hier Intersect(.EntireRow, Range("M:O")).ClearContents 'hier Intersect(.EntireRow, Range("E:L")).Value = "¨" 'und hier End With Application.EnableEvents = True End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBereich As Range Set rngBereich = Range("A9:A36,A41:A67") If Not Intersect(Target, rngBereich) Is Nothing Then 'hier Application.EnableEvents = False If Target.Cells(1) > "" Then If Cells(Target.Row, "D") = "" Then Cells(Target.Row, "D") = "K?" End If ElseIf Target.Cells(1) = "" Then With Intersect(rngBereich, Target) Intersect(.EntireRow, Range("D:D")).ClearContents 'hier Intersect(.EntireRow, Range("M:O")).ClearContents 'hier Intersect(.EntireRow, Range("E:L")).Value = "¨" 'und hier End With End If Application.EnableEvents = True End If End Sub

Vielen Dank... so funktioniert das! 😉

Ich habe meine eigenen Checkboxen simuliert... da die Anzahl meiner Steuerelemente zu hoch war und die Tabelle somit viel zu langsam.
Die Pünktchen stehen schon drin und werden durch Mausklick auf die Zelle gesetzt bzw. geändert.

Hier mal mein ganzer Code:


Private Sub Worksheet_Activate()
Range("E4").Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Count > 1 Then
ActiveCell.Select
Else
If Not Intersect(Target, Range("E9:L36,E41:L67")) Is Nothing Then
Target.Value = IIf(Target.Value = "ý", "¨", "ý")
Cancel = True
Cells(ActiveCell.Row, 1).Select
End If
End If

If Range("E4").Value = "" Then
Range("E4").Value = "'-Bitte eingeben!-"
End If
If Range("E5").Value = "" Then
Range("E5").Value = "'-Bitte auswählen!-"
End If

Dim rngBereich As Range
    
      Set rngBereich = Range("A9:A36,A41:A67")
      If Not Intersect(Target, rngBereich) Is Nothing Then
        Application.EnableEvents = False
        If Target.Cells(1) > "" Then
           If Cells(Target.Row, "D") = "" Then
              Cells(Target.Row, "D") = "K?"
           End If
       ElseIf Target.Cells(1) = "" Then
           With Intersect(rngBereich, Target)
              Intersect(.EntireRow, Range("D:D")).ClearContents
              Intersect(.EntireRow, Range("M:O")).ClearContents
              Intersect(.EntireRow, Range("E:L")).Value = "¨"
           End With
          
        End If
        Application.EnableEvents = True
      End If
  
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngBereich As Range
    
      Set rngBereich = Range("A9:A36,A41:A67")
      If Not Intersect(Target, rngBereich) Is Nothing Then
        Application.EnableEvents = False
        If Target.Cells(1) > "" Then
           If Cells(Target.Row, "D") = "" Then
              Cells(Target.Row, "D") = "K?"
           End If
       ElseIf Target.Cells(1) = "" Then
           With Intersect(rngBereich, Target)
              Intersect(.EntireRow, Range("D:D")).ClearContents
              Intersect(.EntireRow, Range("M:O")).ClearContents
              Intersect(.EntireRow, Range("E:L")).Value = "¨"
           End With
          
        End If
        Application.EnableEvents = True
      End If
      
    If Target.Address = "$E$4" Then
      MsgBox "Bitte Schicht auswählen!", vbOKOnly, "Info"
      Range("E5").Select
    End If
    If Target.Address = "$E$5" Then
      Range("A9").Select
    End If
    
End Sub

Sicherlich noch nicht ganz perfekt... aber so zumindest ausreichend. 😁
Wenn Interesse besteht kann ich auch mal die File uploaden.

Beliebteste Forumthreads (12 Monate)

Wenn Spalte A leer, dann... (VBA)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Wenn Spalte A leer, dann... (VBA)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread