automatische einträge erzeugen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim lz As Long, i As Long Dim Ber As Range, z As Range Set Ber = Intersect(Target, Rows(1)) For Each z In Target If z.Count = 1 And z.Row = 1 Then lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536) If z.Value = "" Then Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents Else For i = 2 To lz If Cells(i, 1) <> "" Then Cells(i, z.Column).Value = 1 End If Next i End If End If Next z End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim lz As Long, i As Long Dim Ber As Range, z As Range Set Ber = Intersect(Target, Rows(1)) Application.EnableEvents = False For Each z In Target lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536) If z.Value = "" Then Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents Else If WorksheetFunction.CountA(z.EntireColumn) <= 1 Then For i = 2 To lz If Cells(i, 1) <> "" Then Cells(i, z.Column).Value = 1 End If Next i End If End If Next z Application.EnableEvents = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim lz As Long, i As Long Dim Ber As Range, z As Range Set Ber = Intersect(Target, Range("C1:IV1")) If Ber Is Nothing Then Exit Sub Application.EnableEvents = False For Each z In Ber lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536) If z.Value = "" Then Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents Else If WorksheetFunction.CountA(z.EntireColumn) <= 1 Then For i = 2 To lz If Cells(i, 1) <> "" Then Cells(i, z.Column).Value = 1 End If Next i End If End If Next z Application.EnableEvents = True End Sub

Hallo Sören,
Also, mal sehen:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim lz As Long, i As Long
Dim Ber As Range, z As Range
' Ber wird als Schnittmenge aus den geänderten Zellen und C1:IV1 gesetzt:
Set Ber = Intersect(Target, Range("C1:IV1"))
' Wenn in C1:IV1 nichts geändert wurde, dann fertig
If Ber Is Nothing Then Exit Sub
' die Ereignisprozeduren werden abgeschaltet (damit in folgenden Befehlen, die eine
' Zelländerung bewirken, die Prozedur nicht erneut aufgerufen wird:
Application.EnableEvents = False
' Für jede Zelle im Bereich (also alle in Zeile 1 geänderten Zellen):
For Each z In Ber
'lz ist die Zeilennummer der letzten beschriebenen Zelle in Spalte A:
lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536)
'Wenn ein Eintrag gelöscht wurde:
If z.Value = "" Then
'lösche Spalte ab Zeile 2
Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents
'sonst:
Else
'Wenn in der Spalte höchstens 1 Wert steht (bei neuer Spalte)
' (VBA-Version von ANZAHL2()
If WorksheetFunction.CountA(z.EntireColumn) <= 1 Then
'Schreibe in jede Zeile, in der in Spalte A etwas steht, eine 1 (=100%)
For i = 2 To lz
If Cells(i, 1) <> "" Then
Cells(i, z.Column).Value = 1
End If
Next i
End If
End If
Next z
'Ereignisprozeduren wieder aktivieren (wichtig!)
Application.EnableEvents = True
End Sub

Ich hoffe, das hat weitergeholfen.
Gruß Matthias

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread