Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
772to776
772to776
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Dateien nach 12 Monaten löschen

Forumthread: 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
Anzeige

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 Integer) As 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 Nothing) Then
        ' 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 Nothing) Then
            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)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige