Microsoft Excel

Herbers Excel/VBA-Archiv

Protokoll


Betrifft: Protokoll
von: Thomas
Geschrieben am: 16.12.2018 12:02:36

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:="<" & CLng(Date) - 720
.Offset(1, 0).Resize(.Rows.Count - 1).EntireRow.Delete
'.AutoFilter
'ShowAllData
.AutoFilter Field:=1
End With

End If

mfg thomas

  

Betrifft: AW: Protokoll
von: Sepp
Geschrieben am: 16.12.2018 12:49:21

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



  

Betrifft: riesen dank an Sepp
von: Thomas
Geschrieben am: 16.12.2018 13:54:30

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


  

Betrifft: AW: riesen dank an Sepp
von: Thomas
Geschrieben am: 16.12.2018 13:56:13

Ist auch wahnsinnig schnell cool.