I have adapted a wonderful bit of code to fulfil the renaming of my files however, when it runs it crashes if a the directory has nothing in it. Can some one advise/adapt the code to identify the directory is empty, display a message informing me that it is and go back to the browser.
Thanks
Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
Dim wbNew As Workbook, wsNew As Worksheet
ToggleStuff False 'turn of screenupdating
Set objFSO = New FileSystemObject 'set a new object in memory
strSourceFolder = BrowseFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub
'Clear old data
Call CleanUp
Kill ("C:\SNDATA\eReport\*.GIF")
Set wbNew = ActiveWorkbook
Set wsNew = wbNew.Sheets(1) 'set the worksheet
wsNew.Activate
With wsNew.Range("A1:B1")
.Value = Array("File", "Full Path")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With
With Application.FileSearch
.LookIn = strSourceFolder 'look in the folder browsed to
.FileType = msoFileTypeAllFiles 'get all files
.SearchSubFolders = True 'search sub directories
.Execute 'run the search
For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
i = x 'make the variable i = x
If x > 60000 Then 'if there happens to be more than multipls of 60,000 files, then add a new sheet
i = x - 60000 'set i to the right number for row placement below
Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
With wsNew.Range("A2:B2")
.Value = Array("File", "Size")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With
End If
On Error GoTo Skip 'in the event of a permissions error
Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
With wsNew.Cells(2, 1) 'populate the next row with the variable data
.Offset(i, 0) = objFile.Name
.Offset(i, 1) = objFile.Path
End With
' Next objFile
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
Next x
wsNew.Columns("A:B").AutoFit
End With
'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
Call DeleteNonPrsParts
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Range("A65500").Select
Selection.End(xlUp).Select
Range(Selection, Cells(1)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Sheet3").Select
End Sub
Bookmarks