Excel 2007
This will work on a single folder. It looks kind of complicated, but
that's because it sends the files to the recycling bin so you can
review before complete deletion. I opted to use that instead of
checking file date, etc, which are unreliable means of determining
whether a file deserves deletion. I didn't bother doing any kind of
browse folder functionality.
Private Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Private Const FO_DELETE = &H3
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_ALLOWUNDO = &H40
Private Declare Function SHFileOperation _
Lib "shell32.dll" Alias "SHFileOperationA" _
(ByRef lpFileOp As SHFILEOPSTRUCT) As Long
Sub Recycle(ByVal fileName As String)
Dim uFileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
'Fill the UDT with information about what to do
With uFileOperation
.wFunc = FO_DELETE
.pFrom = fileName
.pTo = vbNullChar
.fFlags = _
FOF_SILENT + FOF_NOCONFIRMATION + FOF_ALLOWUNDO
End With
'Pass the UDT to the function
lReturn = SHFileOperation(uFileOperation)
If lReturn < 0 Then
Err.Raise vbObjectError + 1, "Error deleting file."
End If
End Sub
Public Sub deleteExcel2003files()
Dim path As String
Dim fileName As String
Dim fileCount As Long
Dim rngMatch As Excel.Range
Dim i As Long
Dim wsh As Excel.Worksheet
path = Application.InputBox("Enter folder path: ")
If (Right$(path, 1) < "\") Then
path = path & "\"
End If
Set wsh = ThisWorkbook.Worksheets.Add
On Error Resume Next
wsh.Name = "OldFiles"
If Err.Number < 0 Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("OldFiles").Delete
Application.DisplayAlerts = True
wsh.Name = "OldFiles"
End If
On Error GoTo 0
fileName = Dir(path & "*.xls*", vbNormal)
fileCount = 0
With wsh
While Len(fileName)
fileCount = fileCount + 1
.Cells(fileCount, 1).Value = fileName
If Len(fileName) - InStrRev(fileName, ".") = 4 Then
.Cells(fileCount, 2).Value = _
Left$(fileName, Len(fileName) - 1)
End If
fileName = Dir()
Wend
If fileCount < 1 Then
Call MsgBox("No files found!")
Exit Sub
End If
For i = 1 To fileCount
If Len(.Cells(i, 2).Value) Then
Set rngMatch = .Range("$A1:$A" & _
fileCount).Find(.Cells(i, 2).Value)
If Not (rngMatch Is Nothing) Then
Recycle (path & .Cells(i, 2).Value)
End If
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub
|