ExcelBanter - Duplicate File Macro in Excel

1) Use the ListFilesToWorksheet() macro to list files to a worksheet,
2) Sort on Column C to help identify duplicate files
3) Delete the rows of filenames/file locations that you DON'T want to erase.
3) Put your cursor on the 1st file you DO want to erase.
Probably cell A3
4) Make sure that the list contains ONLY THE FILES YOU WANT TO ERASE.
5) Use the DeleteMultiFileNames_FromList() macro to delete the files in the
list.

HTH,
--
Gary Brown

If this post was helpful, please click the ''Yes'' button next to ''Was this
Post Helpfull to you?''.

'/==================================================/
'START COPYING MACRO FROM HERE....
Option Explicit

'created using John Walkenbach's
' "Microsoft Excel 2000 Power
' Programming with VBA" example as a
' basic starting point
'================================================= ===
'32-bit API declarations
Private Declare Function SHGetPathFromIDList _
Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder _
Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

'================================================= ===
'Public Type BROWSEINFO
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'================================================= ===

Public Sub ListFilesToWorksheet()
On Error Resume Next
'History:
' 07/15/2000 added hyperlink
' 07/17/2000 added filename filter
' 07/20/2000 added # files found info & criteria info
' 07/27/2000 added extension as separate column
' 08/03/2000 changed # files found to 'count' formula
' 10/23/2000 add status bar 'Wait' message
Dim blnSubFolders As Boolean
Dim dblLastRow As Long
Dim i As Integer, r As Integer, x As Integer
Dim y As Integer, iWorksheets As Integer
Dim Msg As String, Directory As String, strPath As String
Dim strResultsTableName As String, strFilename As String
Dim strWorksheetName As String
Dim strFileNameFilter As String, strDefaultMatch As String
Dim strExtension As String, strFileBoxDesc As String
Dim strMessage_Wait1 As String, strMessage_Wait2 As String
Dim varSubFolders As Variant, varAnswer As String

're-set classes that have lost scope
' This call is in all 'Favorites'
Call Class_Reinitialization

'/==========Variables=============
strResultsTableName = "File_Listing"
strDefaultMatch = "*.*"
r = 1
i = 1
blnSubFolders = False
strMessage_Wait1 = _
"Please wait while search is in progress..."
strMessage_Wait2 = _
"Please wait while formatting is completed..."
'/==========Variables=============

strFileNameFilter = _
InputBox("Ex: *.* with find all files" & vbCr & _
" blank will find all Office files" & vbCr & _
" *.xls will find all Excel files" & vbCr & _
" G*.doc will find all Word files beginning with G" _
& vbCr & _
" Test.txt will find only the files named TEST.TXT" _
& vbCr, _
"Enter file name to match:", Default:=strDefaultMatch)

If Len(strFileNameFilter) = 0 Then
varAnswer = _
MsgBox("Continue Search?", vbExclamation + vbYesNo, _
"Cancel or Continue...")
If varAnswer = vbNo Then
GoTo Exit_ListFiles
End If
End If

If Len(strFileNameFilter) = 0 Then
strFileBoxDesc = "All MSOffice files"
Else
strFileBoxDesc = strFileNameFilter
End If

Msg = "Look for: " & strFileBoxDesc & vbCrLf & _
" - Select location of files to be " & _
"listed or press Cancel."
Directory = GetDirectory(Msg)

If Directory = "" Then
Exit Sub
End If

If Right(Directory, 1) < Application.PathSeparator Then
Directory = Directory & Application.PathSeparator
End If

varSubFolders = _
MsgBox("Search Sub-Folders of " & Directory & " ?", _
vbInformation + vbYesNoCancel, "Search Sub-Folders?")

If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Sub

'check for an active workbook
' if no workbooks open, create one
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If

'save name of current worksheet
strWorksheetName = ActiveSheet.name

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
Exit For
End If
Next

'Add new worksheet where results will be located
Worksheets.Add.Move after:=Worksheets(ActiveSheet.name)

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Hyperlink"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Path"
ActiveWorkbook.ActiveSheet.Range("C1").value = "FileName"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Extension"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Size"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Date/Time"
Range("A1:E1").Font.Bold = True

r = r + 1

On Error Resume Next
Application.StatusBar = strMessage_Wait1
With Application.FileSearch
.NewSearch
.LookIn = Directory
If strFileNameFilter = "*.*" Then _
.FileType = msoFileTypeAllFiles
If Len(strFileNameFilter) = 0 Then _
.FileType = msoFileTypeOfficeFiles
.Filename = strFileNameFilter
.SearchSubFolders = blnSubFolders
.Execute
For i = 1 To .FoundFiles.Count
strFilename = ""
strPath = ""
For y = Len(.FoundFiles(i)) To 1 Step -1
If Mid(.FoundFiles(i), y, 1) = _
Application.PathSeparator Then
Exit For
End If
strFilename = _
Mid(.FoundFiles(i), y, 1) & strFilename
Next y
strPath = _
Left(.FoundFiles(i), _
Len(.FoundFiles(i)) - Len(strFilename))
strExtension = ""
For y = Len(strFilename) To 1 Step -1
If Mid(strFilename, y, 1) = "." Then
If Len(strFilename) - y < 0 Then
strExtension = Right(strFilename, _
Len(strFilename) - y)
strFilename = Left(strFilename, y - 1)
Exit For
End If
End If
Next y
Cells(r, 1) = .FoundFiles(i)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), _
Address:=.FoundFiles(i)
Cells(r, 2) = strPath
Cells(r, 3) = strFilename
Cells(r, 4) = strExtension
Cells(r, 5) = FileLen(.FoundFiles(i))
Cells(r, 6) = FileDateTime(.FoundFiles(i))
r = r + 1
Next i
End With

'formatting
Application.StatusBar = strMessage_Wait2
ActiveWindow.Zoom = 75
Columns("E:E").Select
With Selection
.NumberFormat = _
"_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
End With
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Columns("A:F").EntireColumn.AutoFit
Columns("A:A").Select
If Selection.ColumnWidth 12 Then
Selection.ColumnWidth = 12
End If

Range("A2").Select
ActiveWindow.FreezePanes = True

Rows("1:1").Select
Selection.Insert Shift:=xlDown

dblLastRow = 65000

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
If Len(strFileNameFilter) = 0 Then
strFileNameFilter = "All MSOffice products"
End If
If blnSubFolders Then
Directory = "(including Subfolders) - " & Directory
End If

Application.ActiveCell.Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & _
" files(s) found for Criteria: " & _
Directory & strFileNameFilter & Chr(34)
Selection.Font.Bold = True

Range("B3").Select
Selection.Sort Key1:=Range("B3"), _
Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom

Range("A3").Select

Application.Dialogs(xlDialogWorkbookName).Show

Exit_ListFiles:
Application.StatusBar = False
Exit Sub

Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles

End Sub

'================================================= ==
Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim iFileSystemDirectoriesOnly As Long
Dim iDialogType As Long
Dim iBrowseForComputers As Long
Dim iBrowseForPrinters As Long
Dim iBrowseIncludesFiles As Long
Dim Path As String
Dim r As Long, x As Long, Pos As Integer

iFileSystemDirectoriesOnly = 0
iDialogType = 0
iBrowseForComputers = 0
iBrowseForPrinters = 0
iBrowseIncludesFiles = 0
'- - - - - - - - - - - - - - - - -
' Only return file system directories.
iFileSystemDirectoriesOnly = &H1
' Dialog style with context menu and resizability
' iDialogType = &H40
' Only returns computers
' iBrowseForComputers = &H1000
' Only return printers
' iBrowseForPrinters = &H2000
' The browse dialog will display files as well as folders
' iBrowseIncludesFiles = &H4000

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
' bInfo.ulFlags = &H1
bInfo.ulFlags = _
iFileSystemDirectoriesOnly + _
iDialogType + _
iBrowseForComputers + _
iBrowseForPrinters + _
iBrowseIncludesFiles

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
Pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, Pos - 1)
Else
GetDirectory = ""
End If
End Function
'/================================================/
' Sub Purpose:
'This procedure DELETES all valid files in a list.
' The procedure can be stopped by pressing the ESC key
'Active cell must be in 1st column of data
'This procedure starts from the cursor and goes down
' to the end of the data. There can be no blank cells
' in the list of data.
'Data format:
' 1st column of data - Full Path and file name of files
' to be deleted
' i.e. C:\Temp\Test.txt
'
Public Sub DeleteMultiFileNames_FromList()
Dim blnError As Boolean
Dim iCount As Double
Dim i As Long
Dim varAnswer As Variant

On Error GoTo err_Sub

blnError = False

'xlDisabled = 0 'totally disables Esc /
'Ctrl-Break / Command-Period
'xlInterrupt = 1 'go to debug
'xlErrorHandler = 2 'go to error handler
'Trappable error is #18
Application.EnableCancelKey = xlErrorHandler

'Check if client wants to continue with delete
varAnswer = _
MsgBox("Do you want to DELETE this list of files?", _
vbCritical + vbYesNo + vbDefaultButton2, _
"Select 'Yes' to continue...")
If varAnswer < vbYes Then
MsgBox "Delete halted by User.", _
vbInformation + vbOKOnly, "Warning..."
GoTo exit_Sub
End If

'check for an active workbook
' if no workbooks open, create one
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If

'check to see if active cell has anything in it
If Len(ActiveCell.value) = 0 Then
MsgBox "Please put your cursor in a " & _
"cell with a current " & _
"Full Path and File Name.", _
vbExclamation + vbOKOnly, _
"Warning...Error"
GoTo exit_Sub
End If

iCount = _
ActiveSheet.UsedRange.CurrentRegion.Rows.Count + _
ActiveSheet.UsedRange.CurrentRegion.Row - _
ActiveCell.Row
i = 0

'go down list and delete files in list
Do While True
Err.Clear

blnError = False

'check if at end of list, if so, stop deleting files
If Len(ActiveCell.value) = 0 Then
Exit Do
End If

'delete file listed in current cell
Kill ActiveCell.value

i = i + 1

'go to next cell
ActiveCell.Offset(1, 0).Activate

Loop

exit_Sub:
On Error Resume Next
Application.StatusBar = False
Exit Sub

err_Sub:
If Err.Number = 53 Then 'Error 53 = File not found
blnError = True
Resume Next 'continue on from where error occured
End If

If Err.Number = 18 Then
If MsgBox("You have stopped the process." & _
vbCr & vbCr & _
"QUIT now?", vbCritical + vbYesNo + vbDefaultButton1, _
"User Interrupt Occured...") = vbNo Then
Resume 'continue on from where error occured
End If
End If

Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: DeleteMultiFileNames_FromList - " & _
"Module: Mod_File_Multi_Copy_Delete - " & Now()

Resume Next

End Sub
'/==========================================/
'END OF MACRO....
'
'
'