Datum und Benutzer eintragen

Moin moin,

ich bräuchte mal etwas Hilfe von den VBA-Experten hier im Forum.
Folgendes Prozedere möchte ich realisieren, stehe aber dabei irgendwie auf dem Schlauch, da ich nicht sehr bewandert in Excel-VBA bin.
Wenn ich z. Bsp. in den Zellbereichen C10 bis C200 oder D10 bis D200 etwas eintrage, dann soll in der jeweils gleichen Zeile in Spalte F das Datum und in der gleichen Zeile in Spalte G der Benutzer eingetragen werden. Datum und Benutzer sollen dabei eingefroren werden und sich erst wieder ändern, wenn ein neuer Eintrag erfolgt. Folgenden Code habe ich versucht, aber dabei wird leider die Abfrage für die Zellbereiche in Spalte D ignoriert.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("C10:C200")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then
Target.Offset(0, 3).ClearContents
Target.Offset(0, 4).ClearContents
Else
Target.Offset(0, 3) = Date
Target.Offset(0, 4) = Environ("username")

If Intersect(Target, Range("D10:D200")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then
Target.Offset(0, 2).ClearContents
Target.Offset(0, 3).ClearContents
Else
Target.Offset(0, 2) = Date
Target.Offset(0, 3) = Environ("username")

End If
End If

End Sub

Bedanke mich jetzt schonmal für Eure Hilfe!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Moin GH!

du hast versucht, die Bereiche nacheinander abzuarbeiten, was im Prinzip zwar möglich, aber unnötig ist.
Der Fehler in deiner Logik ist, dass du bei "nicht spalte C" EXIT SUB vorschreibst, dann aber erwartest, dass Spalte "D" noch abgefragt wird.
Exit sub ist exit sub. ende.
Deine Prozedur logisch richtig säh so aus:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub ' Bedingung vorgezogen

    If Not Intersect(Target, Range("C10:C200")) Is Nothing Then 'Bedingung umgekehrt
        If Target = "" Then
            Target.Offset(0, 3).ClearContents
            Target.Offset(0, 4).ClearContents
        Else
            Target.Offset(0, 3) = Date
            Target.Offset(0, 4) = Environ("username")
        End If
    End If

    If Intersect(Target, Range("D10:D200")) Is Nothing Then Exit Sub
    If Target = "" Then
        Target.Offset(0, 2).ClearContents
        Target.Offset(0, 3).ClearContents
    Else
        Target.Offset(0, 2) = Date
        Target.Offset(0, 3) = Environ("username")
    End If
End Sub

Wie gesagt, an sich funktional, aber auch hier machen wir nicht so gern was doppelt.
Nach meiner Ansicht könnte es optimiert so aussehen:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub ' Bedingung vorgezogen
    If Intersect(Target, Range("C10:D200")) Is Nothing Then Exit Sub
    
    If Target = "" Then
        Target.Offset(0, 6 - Target.Column).ClearContents
        Target.Offset(0, 7 - Target.Column).ClearContents
    Else
        Target.Offset(0, 6 - Target.Column) = Date
        Target.Offset(0, 7 - Target.Column) = Environ("username")
    End If
End Sub

Viel Erfolg
Gruß, MCO

If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("C10:C200,D10:D200")) Is Nothing Then If Target = "" Then Cells(Target.Row, 6).ClearContents Cells(Target.Row, 7).ClearContents Else Cells(Target.Row, 6) = Date Cells(Target.Row, 7) = Environ("username") End If End If

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim Zelle As Range If Not Intersect(Target, Range("C10:C200,D10:D200")) Is Nothing Then Cancel = True For Each Zelle In Selection If Zelle > "" Then 'Zelle.ClearContents 'Falls gewuenscht Cells(Zelle.Row, 6).Resize(1, 2).ClearContents End If Next End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("C10:C200,D10:D200")) Is Nothing Then If Target = "" Then Cells(Target.Row, 6).ClearContents Cells(Target.Row, 7).ClearContents Else Cells(Target.Row, 6) = Date Cells(Target.Row, 7) = Environ("username") End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" Dim Zelle As Range If Not Intersect(Target, Range("C10:C200,D10:D200")) Is Nothing Then For Each Zelle In Target Application.EnableEvents = False If Zelle = "" Then Cells(Zelle.Row, 6).ClearContents Cells(Zelle.Row, 7).ClearContents Else Cells(Zelle.Row, 6) = Date Cells(Zelle.Row, 7) = Environ("username") End If Next End If '*** Fehlerbehandlung Err.Clear Fehler: Application.EnableEvents = True If Err.Number > 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _ & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Me.Range("F20:G20").Interior.Color = Me.Range("C20").DisplayFormat.Interior.Color Me.Range("F21:G21").Interior.Color = Me.Range("C21").DisplayFormat.Interior.Color Me.Range("F22:G22").Interior.Color = Me.Range("C22").DisplayFormat.Interior.Color Me.Range("F23:G23").Interior.Color = Me.Range("C23").DisplayFormat.Interior.Color Me.Range("F24:G24").Interior.Color = Me.Range("C24").DisplayFormat.Interior.Color End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i As Integer For i = 20 To 200 Cells(i, 6).Resize(1, 2).Interior.Color = Cells(i, 3).DisplayFormat.Interior.Color Next End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread