Get File list from folders and subfolders Excel VBA - excel

I already have a script that gets list of file in a folder but I need to include subfolders as well, can you please help me modify this, I have tried to compile something from the answers found here but failed.
Sub getfiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel reports")
For Each oFile In oFolder.Files
If oFile.DateLastModified > Now - 7 Then
Cells(i + 1, 1) = oFolder.Path
Cells(i + 1, 2) = oFile.Name
Cells(i + 1, 3) = "RO"
Cells(i + 1, 4) = oFile.DateLastModified
i = i + 1
End If
Next oFile

Here's a non-recursive method:
Sub getfiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object, sf
Dim i As Integer, colFolders As New Collection, ws As Worksheet
Set ws = ActiveSheet
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel")
colFolders.Add oFolder 'start with this folder
Do While colFolders.Count > 0 'process all folders
Set oFolder = colFolders(1) 'get a folder to process
colFolders.Remove 1 'remove item at index 1
For Each oFile In oFolder.Files
If oFile.DateLastModified > Now - 7 Then
ws.Cells(i + 1, 1) = oFolder.Path
ws.Cells(i + 1, 2) = oFile.Name
ws.Cells(i + 1, 3) = "RO"
ws.Cells(i + 1, 4) = oFile.DateLastModified
i = i + 1
End If
Next oFile
'add any subfolders to the collection for processing
For Each sf In oFolder.subfolders
colFolders.Add sf
Next sf
Loop
End Sub

Here's a much simpler and faster method. This should write all the results in a text file and all you have to do is to open that file and read its contents.
Sub List_All_Files_And_SubFolders()
PID = Shell("cmd /k dir c:\test /s /b > c:\test\all_files.txt", vbHide)
While IsFileInUse() = True: DoEvents: Wend
End Sub
Function IsFileInUse()
On Error GoTo Error_Handeling
IsFileInUse = True
Name "c:\test\all_files.txt" As "c:\test\all_files1.txt"
Name "c:\test\all_files1.txt" As "c:\test\all_files.txt"
IsFileInUse = False
Error_Handeling:
If Err.Description = "Path/File access error" Then IsFileInUse = True: Exit Function
End Function

You can do it this way.
Sub FileListingAllFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Under Tools, set a reference to 'Microsoft Scripting Runtime'.

#Tadas: "...but somehow it doesn't even show up as a macro and I can not run it."
Try declaring the sub as Public, e.g. Public Sub FileListingAllFolder() .
Private subs and private functions do not show up in the Macros list.

I became motivated to provide for myself with a kind of universal function which returns a collection of folder objects plus optionally all sub-folders all in ascending order. The collection then may be used for any purpose just by looping through the collection. The function looks as follows:
Public Function Folders(Optional ByVal fo_spec As String = vbNullString, _
Optional ByVal fo_subfolders As Boolean = False, _
Optional ByRef fo_result As String) As Collection
' ----------------------------------------------------------------------------
' Returns all folders in a folder (fo_spec) - optionally including all
' sub-folders (fo_subfolders = True) - as folder objects in ascending order.
' When no folder (fo_spec) is provided a folder selection dialog request one.
' When the provided folder does not exist or no folder is selected the
' the function returns with an empty collection. The provided or selected
' folder is returned (fo_result).
' ----------------------------------------------------------------------------
Static cll As Collection
Static Queue As Collection ' FiFo queue for folders with sub-folders
Static Stack As Collection ' LiFo stack for recursive calls
Static foStart As Folder
Dim aFolders() As Variant
Dim fl As File
Dim flStart As Folder
Dim fo1 As Folder
Dim fo2 As Folder
Dim fso As New FileSystemObject
Dim i As Long
Dim j As Long
Dim s As String
Dim v As Variant
If cll Is Nothing Then Set cll = New Collection
If Queue Is Nothing Then Set Queue = New Collection
If Stack Is Nothing Then Set Stack = New Collection
If Queue.Count = 0 Then
'~~ Provide the folder to start with - when not provided by fo_spec via a selection dialog
If fo_spec <> vbNullString Then
If Not fso.FolderExists(fo_spec) Then
fo_result = fo_spec
GoTo xt
End If
Set fo1 = fso.GetFolder(fo_spec)
Else
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the desired folder!"
.InitialFileName = CurDir
.AllowMultiSelect = False
If .Show <> -1 Then GoTo xt
Set fo1 = fso.GetFolder(.SelectedItems(1))
End With
End If
Set foStart = fo1
Else
'~~ When recursively called (Queue.Count <> 0) take first sub-folder queued
Set fo1 = Queue(1)
End If
For Each fo2 In fo1.SubFolders
cll.Add fo2
If fo1.SubFolders.Count <> 0 And fo_subfolders Then
Queue.Add fo2
End If
Next fo2
Stack.Add cll ' stack result in preparation for the function being called resursively
If Queue.Count > 0 Then
Queue.Remove 1
End If
If Queue.Count > 0 Then
Folders Queue(1).Path ' recursive call for each folder with subfolders
End If
xt: Set fso = Nothing
If Stack.Count > 0 Then
Set cll = Stack(Stack.Count)
Stack.Remove Stack.Count
End If
If Stack.Count = 0 Then
If cll.Count > 0 Then
'~~ Unload cll to array, when fo_subfolders = False only those with a ParentFolder foStart
ReDim aFolders(cll.Count - 1)
For Each v In cll
aFolders(i) = v
i = i + 1
Next v
'~~ Sort array from A to Z
For i = LBound(aFolders) To UBound(aFolders)
For j = i + 1 To UBound(aFolders)
If UCase(aFolders(i)) > UCase(aFolders(j)) Then
s = aFolders(j)
aFolders(j) = aFolders(i)
aFolders(i) = s
End If
Next j
Next i
'~~ Transfer array as folder objects to collection
Set cll = New Collection
For i = LBound(aFolders) To UBound(aFolders)
Set fo1 = fso.GetFolder(aFolders(i))
cll.Add fo1
Next i
End If
Set Folders = cll
If Not foStart Is Nothing Then fo_result = foStart.Path
End If
Set cll = Nothing
End Function
The function had been tested as follows:
Private Sub Folders_Test()
Const TEST_FOLDER = "E:\Ablage\Excel VBA\DevAndTest"
Dim v As Variant
Dim cll As Collection
Dim s As String
Dim sStart As String
Set cll = Folders("c:\XXXX", True, sStart)
s = "1. Test: Folders in a provided non-existing folder ('" & sStart & "')"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
Debug.Assert cll.Count = 0
Set cll = Folders(TEST_FOLDER, , sStart)
s = "2. Test: Folders in the provided folder '" & sStart & "' (without sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(TEST_FOLDER, True, sStart)
s = "3. Test: Folders in the provided folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(, True, sStart)
s = "4. Test: Folders in the manually selected folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
End Sub

Related

Check if files exist based on list of cell values

I need to check if a list of files exist in a certain directory, based on cell values in Excel.
If some files are not found, a message box displays the names of the files that were not found.
I'm unclear if you want to see the files listed in the range that do not appear in the folder or if you want to see the files in the folder that are not in the range.
The following example lists the files in the range that are not in the folder.
I've set up a page for the example, so you may need to adjust your sheet to match, or adjust your code to fit your sheet. Be sure that the folder path you put in B1 has the trailing backslash.
Here's the code:
Sub files_in_folder()
Dim folder As String
Dim filename As String
Dim filenames As Range
Dim cell As Range
Dim s As Worksheet
Dim missing As New Collection
Dim message As String
Dim x As Integer
Set s = ActiveSheet
folder = s.Range("b1").Value
Set filenames = Range(s.Range("b2"), s.Range("b2").End(xlDown))
For Each cell In filenames
If Dir(folder + cell.Value) = "" Then missing.Add cell.Value
Next
If missing.Count = 0 Then
message = "All files were found in " & folder
Else
message = "The following files were not found in " & folder & vbNewLine
For x = 1 To missing.Count
message = message + " " + missing(x) & vbNewLine
Next
End If
MsgBox message
End Sub
Try this.
Sub TestListFilesInFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Result:

Renaming Files in directory not only a folder

I am working on a project in excel, where I am renaming multiple files.
Fow now I am using this code
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "G").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
which lets me change the names of the files in one specific folder, but I would like to be able to pick the main folder containing subfolders and it would change all the names corresponding with names I have made in my excel sheet.
I’m sure you are aware that renaming files if go wrong can have very serious, sometimes even catastrophic consequences, with that been said I hope that all necessary step to avoid any of those problems have been taken.
Data and Code:
It seems that columns A and G contain the "old" and "new" names of the files (excluding the path), and that’s the reason of asking the user for the path and the possibility of running the renaming of the files for subfolders as well.
The code posted compares every file in the folders (and subfolder as expected) against the list of files in the data, which could be time consuming.
Also, I’ll would suggest to have a track of what files have been renamed, so in case of any error, this allows to easily track back and undo what could have be an error.
Solution Proposed
The solution proposed below uses the FileSystemObject object which provides a robust access to the machine file system, you can interact with it in two manners: Early and Late Binding (Visual Basic). These procedures use late binding, to use early binding see How do I use FileSystemObject in VBA?
Folders_ƒGet_From_User: A function that ask the user to select the folder and to process or not subfolders. It returns a list of the subfolder selected (names only), excluding folders with no files.
Files_Get_Array: Creates and array with all the Filenames to be processed (Old & New)
Files_ƒRename: This function renames all files found in any of the folders from the list obtained from point 1. These procedure instead of validating every file present in the subfolders against the list, check if the files in the list Exist in any folder, and if so passes to the function File_ƒRename_Apply that does the renaming and returns the result, allowing the creation of the “Audit Track” array. It returns an array with the results of all the files names in the list in all the folders list ( from point 1 and 2) respectively.
File_Rename_Post_Records: Creates a worksheet named FileRename(Track) (if not present) to post the Audit Track of the results of the Files_ƒRename function.
All of them are called from the procedure: Files_Rename
Let me know of any questions you might have regarding the resources used.
Option Explicit
Private Const mk_Wsh As String = "FileRename(Track)"
Private Const mk_MsgTtl As String = "Files Rename"
Private mo_Fso As Object
…
Sub Files_Rename()
Dim aFolders() As String, aFiles As Variant
Dim aRenamed As Variant
Set mo_Fso = CreateObject("Scripting.FileSystemObject")
If Not (Folders_ƒGet_From_User(aFolders)) Then Exit Sub
Call Files_Get_Array(aFiles)
If Not (Files_ƒRename(aRenamed, aFolders, aFiles)) Then
Call MsgBox("None file was renamed", vbInformation, mk_MsgTtl)
Exit Sub
End If
Call File_Rename_Post_Records(aFiles, aRenamed)
Call MsgBox("Files were renamed" & String(2, vbLf) _
& vbTab & "see details in sheet [" & mk_Wsh & "]", vbInformation, mk_MsgTtl)
End Sub
…
Private Function Folders_ƒGet_From_User(aFolders As Variant) As Boolean
Dim aFdrs As Variant
Dim oFdr As Object, sFolder As String, blSubFdrs As Boolean
Erase aFolders
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function
sFolder = .SelectedItems(1)
End With
If MsgBox("Do you want to include subfolders?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
mk_MsgTtl) = vbYes Then blSubFdrs = True
Set oFdr = mo_Fso.GetFolder(sFolder)
Select Case blSubFdrs
Case False
If oFdr.Files.Count > 0 Then
aFdrs = aFdrs & "|" & oFdr.Path
Else
MsgBox "No files found in folder:" & String(2, vbLf) & _
vbTab & sFolder & String(2, vbLf) & _
vbTab & "Process is being terminated.", _
vbInformation, mk_MsgTtl
Exit Function
End If
Case Else
Call SubFolders_Get_Array(aFdrs, oFdr)
If aFdrs = vbNullString Then
MsgBox "No files found in folder & subfolders:" & String(2, vbLf) & _
vbTab & sFolder & String(2, vbLf) & _
vbTab & "Process is being terminated.", _
vbInformation, mk_MsgTtl
Exit Function
End If
End Select
Rem String To Array
aFdrs = Mid(aFdrs, 2)
aFdrs = Split(aFdrs, "|")
aFolders = aFdrs
Folders_ƒGet_From_User = True
End Function
…
Private Sub SubFolders_Get_Array(aFdrs As Variant, oFdr As Object)
Dim oSfd As Object
With oFdr
If .Files.Count > 0 Then aFdrs = aFdrs & "|" & .Path
For Each oSfd In .SubFolders
Call SubFolders_Get_Array(aFdrs, oSfd)
Next: End With
End Sub
…
Private Sub Files_Get_Array(aFiles As Variant)
Dim lRow As Long
With ThisWorkbook.Sheets("DATA") 'change as required
lRow = .Rows.Count
If Len(.Cells(lRow, 1).Value) = 0 Then lRow = .Cells(lRow, 1).End(xlUp).Row
aFiles = .Cells(2, 1).Resize(-1 + lRow, 7).Value
End With
End Sub
…
Private Function Files_ƒRename(aRenamed As Variant, aFolders As Variant, aFiles As Variant) As Boolean
Dim vRcd As Variant: vRcd = Array("Filename.Old", "Filename.New")
Dim blRenamed As Boolean
Dim oDtn As Object, aRcd() As String, lRow As Long, bFdr As Byte
Dim sNameOld As String, sNameNew As String
Dim sFilename As String, sResult As String
aRenamed = vbNullString
Set oDtn = CreateObject("Scripting.Dictionary")
vRcd = Join(vRcd, "|") & "|" & Join(aFolders, "|")
vRcd = Split(vRcd, "|")
oDtn.Add 0, vRcd
With mo_Fso
For lRow = 1 To UBound(aFiles)
sNameOld = aFiles(lRow, 1)
sNameNew = aFiles(lRow, 7)
vRcd = sNameOld & "|" & sNameNew
For bFdr = 0 To UBound(aFolders)
sResult = Chr(39)
sFilename = .BuildPath(aFolders(bFdr), sNameOld)
If .FileExists(sFilename) Then
If File_ƒRename_Apply(sResult, sNameNew, sFilename) Then blRenamed = True
End If
vRcd = vRcd & "|" & sResult
Next
vRcd = Mid(vRcd, 2)
vRcd = Split(vRcd, "|")
oDtn.Add lRow, vRcd
Next: End With
If Not (blRenamed) Then Exit Function
aRenamed = oDtn.Items
aRenamed = WorksheetFunction.Index(aRenamed, 0, 0)
Files_ƒRename = True
End Function
…
Private Function File_ƒRename_Apply(sResult As String, sNameNew As String, sFileOld As String) As Boolean
With mo_Fso.GetFile(sFileOld)
sResult = .ParentFolder
On Error Resume Next
.Name = sNameNew
If Err.Number <> 0 Then
sResult = "¡Err: " & Err.Number & " - " & Err.Description
Exit Function
End If
On Error GoTo 0
End With
File_ƒRename_Apply = True
End Function
…
Private Sub File_Rename_Post_Records(aFiles As Variant, aRenamed As Variant)
Const kLob As String = "lo.Audit"
Dim blWshNew As Boolean
Dim Wsh As Worksheet, Lob As ListObject, lRow As Long
Rem Worksheet Set\Add
With ThisWorkbook
On Error Resume Next
Set Wsh = .Sheets(mk_Wsh)
On Error GoTo 0
If Wsh Is Nothing Then
.Worksheets.Add After:=.Sheets(.Sheets.Count)
Set Wsh = .Sheets(.Sheets.Count)
blWshNew = True
End If: End With
Rem Set ListObject
With Wsh
.Name = mk_Wsh
.Activate
Application.GoTo .Cells(1), 1
Select Case blWshNew
Case False
Set Lob = .ListObjects(kLob)
lRow = 1 + Lob.ListRows.Count
Case Else
With .Cells(2, 2).Resize(1, 4)
.Value = Array("TimeStamp", "Filename.Old", "Filename.New", "Folder.01")
Set Lob = .Worksheet.ListObjects.Add(xlSrcRange, .Resize(2), , xlYes)
Lob.Name = "lo.Audit"
lRow = 1
End With: End Select: End With
Rem Post Data
With Lob.DataBodyRange.Cells(lRow, 1).Resize(UBound(aRenamed), 1)
.Value = Format(Now, "YYYYMMDD_HHMMSS")
.Offset(0, 1).Resize(, UBound(aRenamed, 2)).Value = aRenamed
.CurrentRegion.Columns.AutoFit
End With
End Sub
Renaming Files (Subfolders)
Not nearly enough tested.
You better create a copy of the folder where it should run to avoid losing files.
It will write all files in the folder and its subfolders to a dictionary object whose keys (file paths) will be checked against the file paths in column A. If matched, the files will be renamed to the name in column G with the same file path.
It checks each new file path only against the file paths in the dictionary before renaming.
It will fail if a file name is not valid.
Copy the complete code to a standard module, e.g. Module1.
Adjust the values in the constants section of the first procedure.
Run only the first procedure, the rest is being called by it.
The Code
Option Explicit
Sub renameFiles()
' Define constants.
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Dim Cols As Variant
Cols = Array("A", "G")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheet.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
' Define Lookup Column Range.
Dim rng As Range
Set rng = defineColumnRange(ws, Cols(LBound(Cols)), FirstRow)
' Write values from Column Ranges to jagged Column Ranges Array.
Dim ColumnRanges As Variant
ColumnRanges = getColumnRanges(rng, Cols)
' Pick a folder.
Dim FolderPath As String
FolderPath = pickFolder
' Define a Dictionary object.
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Write the paths and the names of the files in the folder
' and its subfolders to the Dictionary.
Set dict = getFilesDictionary(FolderPath)
' Rename files.
Dim RenamesCount As Long
RenamesCount = renameColRngDict(ColumnRanges, dict)
' Inform user.
If RenamesCount > 0 Then
MsgBox "Renamed " & RenamesCount & " file(s).", vbInformation, "Success"
Else
MsgBox "No files renamed.", vbExclamation, "No Renames"
End If
End Sub
Function defineColumnRange(Sheet As Worksheet, _
ColumnIndex As Variant, _
FirstRowNumber As Long) _
As Range
Dim rng As Range
Set rng = Sheet.Cells(FirstRowNumber, ColumnIndex) _
.Resize(Sheet.Rows.Count - FirstRowNumber + 1)
Dim cel As Range
Set cel = rng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If Not cel Is Nothing Then
Set defineColumnRange = rng.Resize(cel.Row - FirstRowNumber + 1)
End If
End Function
Function getColumnRanges(ColumnRange As Range, _
BuildColumns As Variant) _
As Variant
Dim Data As Variant
ReDim Data(LBound(BuildColumns) To UBound(BuildColumns))
Dim j As Long
With ColumnRange.Columns(1)
For j = LBound(BuildColumns) To UBound(BuildColumns)
If .Rows.Count > 1 Then
Data(j) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
.Column - .Column).Value
Else
Dim OneCell As Variant
ReDim OneCell(1 To 1, 1 To 1)
Data(j) = OneCell
Data(1, 1) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
.Column - .Column).Value
End If
Next j
End With
getColumnRanges = Data
End Function
Function pickFolder() _
As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
pickFolder = .SelectedItems(1)
End If
End With
End Function
' This cannot run without the 'listFiles' procedure.
Function getFilesDictionary(ByVal FolderPath As String) _
As Object
Dim dict As Object ' ByRef
Set dict = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.FileSystemObject")
listFiles dict, .GetFolder(FolderPath)
End With
Set getFilesDictionary = dict
End Function
' This is being called only by 'getFileDictionary'
Sub listFiles(ByRef Dictionary As Object, _
fsoFolder As Object)
Dim fsoSubFolder As Object
Dim fsoFile As Object
For Each fsoFile In fsoFolder.Files
Dictionary(fsoFile.Path) = Empty 'fsoFile.Name
Next fsoFile
For Each fsoSubFolder In fsoFolder.SubFolders
listFiles Dictionary, fsoSubFolder
Next
End Sub
' Breaking the rules:
' A Sub written as a function to return the number of renamed files.
Function renameColRngDict(ColumnRanges As Variant, _
Dictionary As Object) _
As Long
Dim Key As Variant
Dim CurrentIndex As Variant
Dim NewFilePath As String
For Each Key In Dictionary.Keys
Debug.Print Key
CurrentIndex = Application.Match(Key, _
ColumnRanges(LBound(ColumnRanges)), 0)
If Not IsError(CurrentIndex) Then
NewFilePath = Left(Key, InStrRev(Key, Application.PathSeparator)) _
& ColumnRanges(UBound(ColumnRanges))(CurrentIndex, 1)
If IsError(Application.Match(NewFilePath, Dictionary.Keys, 0)) Then
renameColRngDict = renameColRngDict + 1
Name Key As NewFilePath
End If
End If
Next Key
End Function

How to define path to a folder?

I have code for listing folders, sub folders and filenames. I have to choose a folder by clicking the code.
How it is possible to define path? I have tried to uncomment MyPath but it didn't work.
My path: "\infra\Services\turb"
Sub ListAllFilesInAllFolders()
Dim MyPath As String, MyFolderName As String, MyFileName As String
Dim i As Integer, F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
Dim MySheet As Worksheet
On Error Resume Next
'************************
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing
'************************
'List all folders
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i = i + 1
Loop
'List all files
For Each Key In AllFolders.keys
MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next
'************************
'List all files in Files sheet
For Each MySheet In ThisWorkbook.Worksheets
If MySheet.Name = "Files" Then
Sheets("Files").Cells.Delete
F = True
Exit For
Else
F = False
End If
Next
If Not F Then Sheets.Add.Name = "Files"
'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
---------------- EDIT ---------------------
Same path in another code that is working. This code is doing quite the same but I don't like the output of listing folders.
Option Explicit
Private iColumn As Integer
Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True)
Application.ScreenUpdating = False
Cells.Delete
Range("A1").Select
iColumn = 1
' add headers
With Range("A1")
.Formula = "Folder contents: " & strPath
.Font.Bold = True
.Font.Size = 12
End With
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
ListFolders strPath, bFolders
Application.ScreenUpdating = True
End Sub
ListFolders:
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
' example: ListFolders "C:\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
Dim strfile As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'line added by dr for repeated "Permission Denied" errors
On Error Resume Next
iColumn = iColumn + 1
' display folder properties
ActiveCell.Offset(1).Select
With Cells(ActiveCell.Row, iColumn)
.Formula = SourceFolder.Name
.Font.ColorIndex = 11
.Font.Bold = True
.Select
End With
strfile = Dir(SourceFolder.Path & "\*.*")
If strfile <> vbNullString Then
ActiveCell.Offset(0, 1).Select
Do While strfile <> vbNullString
ActiveCell.Offset(1).Select
ActiveCell.Value = strfile
strfile = Dir
Loop
ActiveCell.Offset(0, -1).Select
End If
Cells(r, 0).Formula = SourceFolder.Name
Cells(r, 3).Formula = SourceFolder.Size
Cells(r, 4).Formula = SourceFolder.SubFolders.Count
Cells(r, 5).Formula = SourceFolder.Files.Count
Cells(r, 6).Formula = SourceFolder.ShortName
Cells(r, 7).Formula = SourceFolder.ShortPath
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
iColumn = iColumn - 1
Next SubFolder
Set SubFolder = Nothing
End If
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Create new worksheet and list sub folders there:
Sub ListAllFilesTurb()
Dim WS As Worksheet
Set WS = Sheets.Add
Sheets.Add.Name = "Turb"
TestListFolders "\\infra\Services\turb"
End Sub
Get rid of the objFolder and objShell (and any dependent conditional code, etc.). Then you should be able to hardcode MyPath. As presently written, this code is using the objShell to browse.
Get rid of this:
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing
Replace with this:
' Define hard-coded folder:
MyPath = "\\infra\Services\turb" '# Modify as needed
NOTE: It is important that the MyPath end with a backslash character, while you can hardcode that on the same line, e.g.:
MyPath = "\\infra\Services\turb\"
It may be best to add a check for it (similar to the original code) just in case you forget, so:
MyPath = "\\infra\Services\turb"
'### Ensure the path ends with a separator:
MyPath = MyPath & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator)

Have PDFs in folders. Need to record the names and locations in Excel

Don't see any questions similar to what I am looking for.
I have about 20k+ PDFs stored in various locations on my C drive. I don't have a complete list of what is available or when they were created.
What I am looking to do is find the names, size and dates that the file was created. These would need to be recorded in an Excel spreadsheet
Note: Some of the PDFs are buried about 6 or 7 folders deep, while some are only 1 folder deep.
Can anybody suggest a way of automatically do it?
I have tried using this code*:
Sub ListAllFiles()
Dim fs As FileSearch, ws As Worksheet, i As Long
Dim r As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = True '
.FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
.LookIn = "H:\My Desktop"
If .Execute > 0 Then
Set ws = Worksheets.Add
r = 1
For i = 1 To .FoundFiles.Count
If Right(.FoundFiles(i), 3) = ".pdf" Or Right(.FoundFiles(i), 3) = ".tif" Then
ws.Cells(r, 1) = .FoundFiles(i)
r = r + 1
End If
Next
Else
MsgBox "No files found"
End If
End With
End Sub
However, this seems to return an issue in the 4th line - application.filesearch
I have also tried this*, which works well, but doesn't go into the folders:
Sub ListAllFile()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = Worksheets.Add
'Get the folder object associated with the directory
Set objFolder = objFSO.GetFolder("H:\My Desktop")
ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
'Loop through the Files collection
For Each objFile In objFolder.Files
If UCase$(Right$(objFile.Name, 4)) = ".PDF" Then
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = Replace$(UCase$(objFile.Name), ".PDF", "")
End If
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Any help would be gratefully appreciated.
these are codes that I found on the net
Maybe this will help
The main function imports the output from the Dos command: Dir C:\*.pdf /S | Find "pdf"
Public Sub listFileTypes(Optional ByVal root As String = "C:\*.", _
Optional ByVal ext As String = "pdf")
Const MAX_SIZE As Long = 17 'max space reserved for file sizes
Dim i As Long, maxRow As Long, maxCol As Long, fInfo As String, ws As Worksheet
Dim arrLines As Variant, s As String, pat As String, midSp As Long
Application.ScreenUpdating = False
Set ws = ActiveSheet
ws.Cells.Delete
s = CreateObject("WScript.Shell").Exec( _
"%comspec% /C Dir """ & root & ext & """ /S | Find """ & ext & """" _
).STDOut.ReadAll
'Application.Wait Now + TimeValue("0:00:01") 'built-in replacement for "Sleep"
If Len(s) > 0 Then
For i = MAX_SIZE To 2 Step -1
s = Replace(s, Space(i), vbTab) 'replace space sets with tabs
Next
arrLines = Split(s, vbCrLf)
maxRow = UBound(arrLines, 1)
With ws
.Cells(1, 1).Value2 = root & ext
For i = 2 To maxRow + 2
If Len(arrLines(i - 2)) > 0 Then
maxCol = UBound(Split(arrLines(i - 2), vbTab))
If maxCol > 0 Then
.Range( _
.Cells(i, 1), _
.Cells(i, maxCol + 1)) = Split(arrLines(i - 2), vbTab)
'split file size from name
fInfo = .Cells(i, maxCol + 1).Value2
midSp = InStr(1, fInfo, " ")
.Cells(i, maxCol + 1).Value2 = Mid(fInfo, 1, midSp)
.Cells(i, maxCol + 2).Value2 = Mid(fInfo, midSp)
End If
End If
Next
.UsedRange.Columns.AutoFit
For i = 1 To 3
.Columns(i).EntireColumn.ColumnWidth = .Columns(i).ColumnWidth + 5
Next
End With
End If
Application.ScreenUpdating = True
End Sub
This is how you can call it:
Public Sub testFileTypes()
listFileTypes "C:\*", "pdf" 'or: listFileTypes "C:\Temp\*", "pdf"
End Sub
It might take a while if you have so many, but it will generate a list similar to this (per drive)

Organizing Files in Excel using VBA and FileSystemObject

I tried to get this to sort in ascending order from the time and it is not quite working right. It adds all the information, but does not sort the value. Also, I need to add a cut-off so it only uploads the files within the last week (7 days) from the current date. I'm not sure of an effective way to do this.
Thanks!
Option Explicit
Sub ListFiles()
Application.ScreenUpdating = False
Sheets("Sheet2").Select
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "File Name:"
Range("C3").Formula = "Creation Date:"
ListFolders "C:\Users\blake.rupprecht\Desktop\Photos\"
Application.ScreenUpdating = True
End Sub
Sub ListFolders(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim r As Long
Dim sfil As String
Dim par As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error Resume Next
sfil = Dir(SourceFolderName & "\" & "*.jpg*")
Do Until sfil = ""
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveCell.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & sfil, , , sfil
ActiveCell.Offset(, 1).Value = SourceFolder.Files(sfil).DateCreated
ActiveCell.Offset(1).Select
sfil = Dir$
Loop
Columns("A:B").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Checking for 7 days tmie span:
If Now - SourceFolder.Files(sfil).DateCreated < 7 Then
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveCell.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & sfil, , , sfil
ActiveCell.Offset(, 1).Value = SourceFolder.Files(sfil).DateCreated
ActiveCell.Offset(1).Select
End If
Please note that the calculation takes time of day into consideration also. If you want just the date, you have to extract integers from operands.
To sort the values, record some sorting and then remodule that code to fit your scenario.
If you want to sort in ascending order, the easiest thing would probably be to add the results to an array, then use a comparison to re-order the array in ascending order, and then write the values to the cells from the array. I'll post an example when I get back to the office.
Code is untested, but should work. Let me know if it doesn't and I'll setup a workbook to test it in. Also, you could break the sorting code out into it's own function, then it's reusable in other routines. Do as you see fit.
I removed the On Error Resume Next statement because it wasn't necessary where you had it. Turning off error notifications is only going to mask errors and make it harder to troubleshoot problems with your code. If you expect errors, write something to handle them, don't just ignore them.
Option Explicit
Sub ListFiles()
Application.ScreenUpdating = False
Sheets("Sheet2").Select
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "File Name:"
Range("C3").Formula = "Creation Date:"
ListFolders "C:\Users\blake.rupprecht\Desktop\Photos\"
Application.ScreenUpdating = True
End Sub
Sub ListFolders(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim r As Long
Dim sfil As String
Dim par As String
Dim lngX As Long
Dim lngY As Long
Dim strX As String
Dim strY As String
Dim strTemp As String
Dim strFiles() As String
ReDim strFiles(0)
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
sfil = Dir(SourceFolderName & "\*.jpg*")
Do Until LenB(sfil) = 0
If Now - SourceFolder.files(sfil).DateCreated < 7 Then
If lngX = 0 And LenB(strFiles(lngX)) = 0 Then
strFiles(0) = sfil
Else
ReDim Preserve strFiles(UBound(strFiles) + 1)
strFiles(UBound(strFiles)) = sfil
End If
End If
Loop
'Sort the array in ascending order
If LenB(srfiles(LBound(strFiles))) > 0 Then
For lngY = 0 To UBound(strFiles) - 1
For lngX = 0 To UBound(strFiles) - 1
'Grab the current and next item in the list to compare
strX = strFiles(lngX)
strY = strFiles(lngX + 1)
'Check if the current item is greater than the next in the list and swap them if it is
If strX > strY Then
strTemp = strFiles(lngX)
strFiles(lngX) = strFiles(lngX + 1)
strFiles(lngX + 1) = strTemp
End If
'Reset the temporary strings so we don't accidentally use the wrong value in case of some unforeseen error
strTemp = vbNullString
strX = vbNullString
strY = vbNullString
Next lngX
Next lngY
End If
For lngX = LBound(strFiles) To UBound(stfiles)
With Range("B" & Rows.Count).End(xlUp).offset(1)
.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & strFiles(lngX), , , strFiles(lngX)
.offset(, 1).Value = SourceFolder.files(strFiles(lngX)).DateCreated
End With
Next
Columns("A:B").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub

Resources