Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1660to1664
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Protokoll

Protokoll
16.12.2018 12:02:36
Thomas
Hallo Excelfreunde,
dank eurer Hilfe schreibe ich ein Änderungsprotokoll. Nun befürchte ich das dieses irgendwann überläuft.
Mein Gedanke ist mit dem unten stehenden Macro alle Daten die älter sind als zwei Jahre zu löschen.
Wie könnte ich es bewerkstelligen das dieses Macro nur einmal im Jahr ausgeführt wird.
Dies hier klappt einfach nicht.
Private Sub Workbook_Open()
If Year(Date) > Year(CDate(FileDateTime(ThisWorkbook.Path))) Then
With Worksheets("Protokoll").Cells(1, 1).CurrentRegion
.AutoFilter Field:=1, Criteria1:=" .Offset(1, 0).Resize(.Rows.Count - 1).EntireRow.Delete
'.AutoFilter
'ShowAllData
.AutoFilter Field:=1
End With
End If
mfg thomas

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Protokoll
16.12.2018 12:49:21
Sepp
Hallo Thomas,
das würde ich schon wieder anders angehen.
Microsoft Excel Objekt DieseArbeitsmappe
Option Explicit 
 
Private Const REF_ADDRESS As String = "A1:Q550" 
Private varOldValue As Variant 
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 
  Dim lngRow As Long, lngMax As Long 
 
  Const MAX_ROWS As Long = 40000  'Maximale Zeilenanzahl unabhängig vom Datum 
  Const MAX_DAYS As Long = 730    'Maximale Tage im Protokoll 
 
  On Error GoTo ErrorHandler 
 
  If Sh.Name <> "Protokoll" Then 
    If Not Intersect(Target, Sh.Range(REF_ADDRESS)) Is Nothing Then 
      If Target.Count = 1 Then 
        Application.EnableEvents = False 
        With Worksheets("Protokoll") 
          lngMax = Evaluate("MIN(IF(('" & .Name & "'!B1:B" & MAX_ROWS & "<=TODAY()-" & MAX_DAYS & _
            ")*('" & .Name & "'!B1:B" & MAX_ROWS & "<>""""),ROW('" & .Name & "'!A1:A" & MAX_ROWS & ")))") 
          If lngMax < MAX_ROWS And lngMax > 0 Then 
            .Range(.Cells(lngMax, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete 
          ElseIf .UsedRange.Rows.Count > MAX_ROWS Then 
            .Range(.Cells(MAX_ROWS, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete 
          End If 
          .Rows(2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 
          .Cells(2, 1).Value = Application.UserName 'Benutzer 
          .Cells(2, 2).Value = Date 'Datum 
          .Cells(2, 3).Value = Time 'Zeit 
          .Cells(2, 4).Value = Sh.Name 'Blattname, auf dem geändert wurde 
          .Cells(2, 5).Value = Sh.Cells(1, Target.Column) 'Spalte 
          .Cells(2, 6).Value = Sh.Cells(Target.Row, 1)  'Datensatznummer 
          .Cells(2, 7).Value = Target.Value 'Neuer Eintrag 
          .Cells(2, 8).Value = varOldValue 'Alter Eintrag 
          .Cells(2, 9).Formula = "=HYPERLINK(_FILE&""'" & Sh.Name & "'!A""&MATCH(" & _
            Sh.Cells(Target.Row, 1) & ",'" & Sh.Name & "'!A:A,0),""Go…"")" 'Link 
        End With 
      End If 
    End If 
  End If 
 
ErrorHandler: 
  Application.EnableEvents = True 
End Sub 
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) 
  If Sh.Name <> "Protokoll" Then 
    If Not Intersect(Target, Sh.Range(REF_ADDRESS)) Is Nothing Then 
      If Target.Count = 1 Then varOldValue = Target 
    End If 
  End If 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Löscht Datensätze die älter als 730 Tage sind oder wenn mehr als 40.000 Zeilen befüllt sind,
außerdem steht der neueste Eintrag immer in Zeile 2.
 ABCDEF
1Gruß Sepp
2
3

Anzeige
riesen dank an Sepp
16.12.2018 13:54:30
Thomas
Hallo Sepp,
ich mach dir ganz schön arbeit.
Hab riesen riesen dank dafür. Es funktioniert super.
Ich weiss gar nicht wie dein Gehirn so etwas schafft, meins regelt nach der zweiten Ebene einfach ab.
Du bist ein cooler Typ.
Ich wünsch Dir vom ganzen Herzen noch ein ruhigen dritten Advent.
MFG Thomas
Hab recht vielen vielen dank
AW: riesen dank an Sepp
16.12.2018 13:56:13
Thomas
Ist auch wahnsinnig schnell cool.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige