15.03.2019, 21:36
Guten Abend Zusammen
ich habe ein Makro gebastelt, in dem bei der Änderung der Zelle in Spalte A in Spalte H das aktuelle Datum eingetragen wird.
Nachteil ist, daß das Datum nicht fix ist. Sobald ich durch die Tabelle blätter und in Spalte A bin wird natürlich das Datum auf das Aktuelle gesetzt.
Dass sollte so nicht sein, weiß aber nicht, wie ich das anders darstellen kann.
Der Code sieht so aus: (Optimierungsvorschläge immer gerne )
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'MS_15.03.2019
Dim TABL As Range 'Variablendeklaration
Set TABL = ActiveSheet.ListObjects("Fragenliste").ListColumns(1).DataBodyRange
If Intersect(Target, TABL) Is Nothing Then Exit Sub 'Datum in Zelle
Cells(Target.Row, 8) = Date
Dim Ws As Worksheet: Set Ws = ActiveSheet 'Variablendeklaration
Dim r As Range, s&, i&
Application.ScreenUpdating = False 'Tabellengröße reduzieren
With Ws.ListObjects(1)
Set r = .DataBodyRange.Resize(.DataBodyRange.Rows.Count, 1)
s = WorksheetFunction.CountA(r)
If s < .ListRows.Count Then
For i = .ListRows.Count To s + 2 Step -1
.ListRows(i).Delete
Next i
End If
End With
Set Ws = Nothing: Set r = Nothing
Application.ScreenUpdating = True
ActiveSheet.ListObjects("Fragenliste").ListRows.Add 'eine Spalte hinzufügen
End Sub
Gruß
Michael
ich habe ein Makro gebastelt, in dem bei der Änderung der Zelle in Spalte A in Spalte H das aktuelle Datum eingetragen wird.
Nachteil ist, daß das Datum nicht fix ist. Sobald ich durch die Tabelle blätter und in Spalte A bin wird natürlich das Datum auf das Aktuelle gesetzt.
Dass sollte so nicht sein, weiß aber nicht, wie ich das anders darstellen kann.
Der Code sieht so aus: (Optimierungsvorschläge immer gerne )
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'MS_15.03.2019
Dim TABL As Range 'Variablendeklaration
Set TABL = ActiveSheet.ListObjects("Fragenliste").ListColumns(1).DataBodyRange
If Intersect(Target, TABL) Is Nothing Then Exit Sub 'Datum in Zelle
Cells(Target.Row, 8) = Date
Dim Ws As Worksheet: Set Ws = ActiveSheet 'Variablendeklaration
Dim r As Range, s&, i&
Application.ScreenUpdating = False 'Tabellengröße reduzieren
With Ws.ListObjects(1)
Set r = .DataBodyRange.Resize(.DataBodyRange.Rows.Count, 1)
s = WorksheetFunction.CountA(r)
If s < .ListRows.Count Then
For i = .ListRows.Count To s + 2 Step -1
.ListRows(i).Delete
Next i
End If
End With
Set Ws = Nothing: Set r = Nothing
Application.ScreenUpdating = True
ActiveSheet.ListObjects("Fragenliste").ListRows.Add 'eine Spalte hinzufügen
End Sub
Gruß
Michael
Win 10
Office 2010 & 2016
Office 2010 & 2016