Anzeige
Archiv - Navigation
772to776
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
772to776
772to776
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Dateien nach 12 Monaten löschen

Dateien nach 12 Monaten löschen
18.06.2006 14:40:52
Stefan
Hallo
Gibt es eine Möglichkeit alle .xls Dateien eines bestimmten Ordners
z.B. D:\Eigene Dateien\Ablage
nach ausführen eines Makros, die älter sind als ca.12 Monate, zu löschen ?
Grüße aus Reutlingen

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Dateien nach 12 Monaten löschen
18.06.2006 14:59:23
Herbert
Hi,
was soll als Ktiterium gelten, Datum der letzten Änderung oder Erstellungsdatum?
mfg Herbert
AW: Dateien nach 12 Monaten löschen
18.06.2006 15:10:11
Stefan
Da eine tägliche automatische Abspeicherung der datei unter neuem Namen stattfindet,
Datum der letzten Änderung
AW: Dateien nach 12 Monaten löschen
18.06.2006 15:19:04
Stefan
entschuldigung falls zu unverständlich !
1.Datei ist ein Formblatt
2.Formblatt ist täglich auszufüllen
3.Wenn ein neues Formblatt benötigt wir (Makro erstellt: "Neues Formblatt")
Speichert er das ausgefüllte ab und erstellt eine neue Datei.
4. Diese Dateien werden normalerweise nur zu Aufbewahrungsfristen gesichert.

Sub Löschen()
' Löschen Makro
' Makro am 15.02.2006 von Stefan aufgezeichnet
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "D:\Eigene Dateien\Ablage\" & Year(Now) & "." & (Month(Now) & "  PügbNr." & _
Range("I2").Value & ".XLS")
Application.DisplayAlerts = True
Sheets("Übergabebogen").Select
Range("Q14:Q25").Select
Selection.ClearContents
Range("Q14").Select
Sheets("Eingabefeld").Select
Range("I1").Select
Selection.Copy
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B5:L5").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("C6:L16").Select
Selection.ClearContents
Range("P5:P16").Select
Selection.Copy
Range("I5").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("Q5:Q16").Select
Selection.Copy
Range("F5").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("B5").Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "D:\Eigene Dateien\Ablage\" & Year(Now) & "." & (Month(Now) & "  PügbNr." & _
Range("I2").Value & ".XLS")
End Sub

Anzeige
AW: Dateien nach 12 Monaten löschen
18.06.2006 15:49:02
Stefan
Denke
Datum der letzten Änderung
währe OK
AW: Dateien nach 12 Monaten löschen
18.06.2006 16:00:39
Peter
Servus,
nach Anpassung deinerseits (siehe grüner Text), müsste es funktionieren.
Code gehört in ein Modul.
Bitte bedenken nach Klicken auf Ja ist das File weg, kein Papierkorb, gar nix, nur weg.


Option Explicit
Sub basFileOlder12Kill()
Dim strDat As String
Dim dblDat As Double: Dim intZ As Integer
Dim myFS As FileSearch
Set myFS = Application.FileSearch
    With myFS
        .NewSearch
        .LookIn = "C:\" 'Ordner anpassen
        .SearchSubFolders = False 'Unterordner durchsuchen, Anpassen
        .Filename = "*.xls" 'Filename anpassen
        .MatchTextExactly = True 'Dateiname muss exakt sein
        .FileType = msoFileTypeAllFiles
        If .Execute > 0 Then
            For intZ = 1 To .FoundFiles.Count
                strDat = GetFileAttributes(.FoundFiles(intZ), 3)
                If strDat = "" Then Exit Sub
                strDat = Left(strDat, InStr(1, strDat, " ") - 1)
                dblDat = DateSerial(--Right(strDat, 4), --Mid(strDat, 4, 2), --Left(strDat, 2))
                If dblDat < CDbl(Date - 365) Then
                   If MsgBox("Datei wirklich löschen ? ( " & .FoundFiles(intZ) & " )", vbYesNo, _
                        "Löschen? Datei ist unwiederruflich gelöscht !") = vbYes Then _
                            Kill .FoundFiles(intZ)
                End If
            Next
        End If
    End With
End Sub
Public Function GetFileAttributes(strFilePath As String, Nummer As IntegerAs String
'Orginal von: p2p.wrox.com/topic.asp?TOPIC_ID=37248
'written by maccas
'Angepasst von Peter W
'###############################################################################################
'Verweis auf Microsoft Shell Controls and Automation / C:\Windows\System32\Shell32.dll
'GUID / Verweis                          Beschreibung                            Hauptnr Nebennr
'{50A7E9B0-70EF-11D1-B75A-00A0C90564FE}  Microsoft Shell Controls And Automation    1        0
'Aufruf z.B. aus Excel (=GetFileAttributes("C:\ati.log";2))
'Aufruf aus VBA z.B. MsgBox GetFileAttributes("C:\ati.log", 2)
'###############################################################################################
' Shell32 objects
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objFolderItem As Shell32.FolderItem
' Other objects
Dim strPath As String
Dim strFileName As String
Dim i As Integer
    ' If the file does not exist then quit out
    If Dir(strFilePath) = "" Then Exit Function
    ' Parse the file name out from the folder path
    strFileName = strFilePath
    i = 1
    Do Until i = 0
        i = InStr(1, strFileName, "\", vbBinaryCompare)
        strFileName = Mid(strFileName, i + 1)
    Loop
    strPath = Left(strFilePath, Len(strFilePath) - Len(strFileName) - 1)
    ' Set up the shell32 Shell object
    Set objShell = New Shell
    ' Set the shell32 folder object
    Set objFolder = objShell.Namespace(strPath)
    ' If we can find the folder then ...
    If (Not objFolder Is NothingThen
        ' Set the shell32 file object
        Set objFolderItem = objFolder.ParseName(strFileName)
        ' If we can find the file then get the file attributes
        If (Not objFolderItem Is NothingThen
            GetFileAttributes = objFolder.GetDetailsOf(objFolderItem, Nummer)
        End If
        Set objFolderItem = Nothing
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
End Function


mfg
Peter
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige