Veränderung festhalten.
18.07.2007 23:31:26
ZekA
Die Tabelle mit dem Code funktioniert zwar, aber irgendwie auch nicht (Bei manchen Zellen ändert sich nichts.) irgendwo im Code ist ein Fehler drinnen und ich weiß nicht wo der Fehler sein könnte.
Bitte um Hilfe. Danke
Der Code ist:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Änderungen Ausweisstaus verfolgen
Dim wks As Worksheet, lngZeile As Long
Set wks = Me
With wks
Application.EnableEvents = False
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letze Zeile mit Eintrag in Spalte A
If Not Intersect(Target, .Range(.Cells(5, 2), wks.Cells(lngZeile, 5))) Is Nothing Then
.Cells(Target.Row, 15).Value = .Cells(Target.Row, 1).Text 'nr. eintragen
'Zeitstempel setzen bei Änderung
.Cells(Target.Row, 17).NumberFormat = "YYYY-MM-DD hh:mm:ss"
.Cells(Target.Row, 17).Value = Now
If Application.WorksheetFunction.CountA(.Range(Cells(Target.Row, 2), _
.Cells(Target.Row, 5))) = 1 Then 'eine Spalte ist markiert
If Application.WorksheetFunction.CountIf(.Range(.Cells(Target.Row, 2), _
.Cells(Target.Row, 5)), "ü") = 0 _
And Application.WorksheetFunction.CountIf(.Range(.Cells(Target.Row, 2), _
.Cells(Target.Row, 5)), "û") = 0 Then
'Sondereintrag (nicht ü oder û)
.Cells(Target.Row, 16).Value = ""
For Spalte = 2 To 5
.Cells(Target.Row, 16).Value = .Cells(Target.Row, 16).Value & _
.Cells(Target.Row, Spalte).Value
Next
Else
For Spalte = 2 To 5
If Not IsEmpty(.Cells(Target.Row, Spalte)) Then
Select Case Spalte
Case 2
.Cells(Target.Row, 16).Value = "am Empfang"
Case 3
.Cells(Target.Row, 16).Value = "vergeben"
Case 4
.Cells(Target.Row, 16).Value = "gesperrt"
Case 5
.Cells(Target.Row, 16).Value = "fehlt"
Case Else
End Select
End If
Next
End If
Else
'2 oder mehr Spalten sind markiert
.Cells(Target.Row, 16).ClearContents
End If
End If
Application.EnableEvents = True
End With
With wks
Application.EnableEvents = False
lngZeile = .Cells(.Rows.Count, 8).End(xlUp).Row 'Letze Zeile mit Eintrag in Spalte A
If Not Intersect(Target, .Range(.Cells(5, 9), wks.Cells(lngZeile, 5))) Is Nothing Then
.Cells(Target.Row, 23).Value = .Cells(Target.Row, 8).Text 'nr. eintragen
'Zeitstempel setzen bei Änderung
.Cells(Target.Row, 25).NumberFormat = "YYYY-MM-DD hh:mm:ss"
.Cells(Target.Row, 25).Value = Now
If Application.WorksheetFunction.CountA(.Range(Cells(Target.Row, 9), _
.Cells(Target.Row, 12))) = 1 Then 'eine Spalte ist markiert
If Application.WorksheetFunction.CountIf(.Range(.Cells(Target.Row, 9), _
.Cells(Target.Row, 12)), "ü") = 0 _
And Application.WorksheetFunction.CountIf(.Range(.Cells(Target.Row, 9), _
.Cells(Target.Row, 12)), "û") = 0 Then
'Sondereintrag (nicht ü oder û)
.Cells(Target.Row, 24).Value = ""
For Spalte1 = 9 To 12
.Cells(Target.Row, 24).Value = .Cells(Target.Row, 24).Value & _
.Cells(Target.Row, Spalte1).Value
Next
Else
For Spalte1 = 9 To 12
If Not IsEmpty(.Cells(Target.Row, Spalte1)) Then
Select Case Spalte1
Case 9
.Cells(Target.Row, 24).Value = "am Empfang"
Case 10
.Cells(Target.Row, 24).Value = "vergeben"
Case 11
.Cells(Target.Row, 24).Value = "gesperrt"
Case 12
.Cells(Target.Row, 24).Value = "fehlt"
Case Else
End Select
End If
Next
End If
Else
'2 oder mehr Spalten sind markiert
.Cells(Target.Row, 24).ClearContents
End If
End If
Application.EnableEvents = True
End With
End Sub
Tabelle:
https://www.herber.de/bbs/user/44217.xls