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
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
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