I'm using the following code to list all files with xls,xlsx or xlsm extension from folder and its subfolder. The following code works but the problem is, it lists all files with all extensions from subfolders but lists only excel files from main folder. I can not figure out whats wrong with this code. Could you please help me?
Sub List_XL_Files(ByVal SheetName As String, ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim lRoMa As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
lRoMa = ThisWorkbook.Sheets(SheetName).Cells(Rows.Count, 2).End(xlUp).Row + 1
ReDim arrFolders(ctr)
With ThisWorkbook.Sheets(SheetName)
For Each FileItem In SourceFolder.Files
strFileExt = FSO.GetExtensionName(FileItem)
If strFileExt = "xlsm" Or strFileExt = "xlsx" Or strFileExt = "xls" Then
MsgBox strFileExt
.Cells(lRoMa + r, 1).Value = lRoMa + r - 7
.Cells(lRoMa + r, 2).Formula = strFileExt
.Cells(lRoMa + r, 3).Formula = FileItem.Name
.Cells(lRoMa + r, 4).Formula = FileItem.Path
.Cells(lRoMa + r, 5).Value = "-"
.Cells(lRoMa + r, 6).Value = ""
.Cells(lRoMa + r, 7).Value = ""
r = r + 1 ' next row number
X = SourceFolder.Path
End If
Next FileItem
End With
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SheetName, SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End sub
Thanks
Add the below code after For Each SubFolder In SourceFolder.SubFolders
Call List_XL_Files(SheetName, SubFolder.Path, True)
It will work
Related
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
I just started working with VBA.
I have a VBA code that counts the number of the occurence of words inside the excel file. It works fine.
I want to run this VBA macro on all files I have inside a specific folder.
Could you help me out?
My code below:
I am getting values right only for the file from which I ran the macro. For the rest of the files, the reults obtained are wrong
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Dim wordList As New Collection
Dim keyList As New Collection
Dim c
Worksheets("Sheet1").Activate
Dim RangeToCheck As Range
Set RangeToCheck = Range("A1:A1000")
For Each c In RangeToCheck
Dim words As Variant
words = Split(c, " ")
For Each w In words
Dim temp
temp = -1
On Error Resume Next
temp = wordList(w)
On Error GoTo 0
If temp = -1 Then
wordList.Add 1, Key:=w
keyList.Add w, Key:=w
Else
wordList.Remove (w)
keyList.Remove (w)
wordList.Add temp + 1, w
keyList.Add w, Key:=w
End If
Next w
Next c
Dim x
Dim k
k = 1
For x = 1 To wordList.Count
With Sheets("Sheet1")
.Cells(k, "E").Value = keyList(x)
.Cells(k, "F").Value = wordList(x)
k = k + 1
End If
End With
Next x
End With
xFileName = Dir
Loop
End If
End Sub
Try this
Public Sub LoopThroughFiles()
Dim xFd As FileDialog
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.AllowMultiSelect = False
If xFd.Show <> -1 Then
MsgBox "No Folder selected": Exit Sub
End If
Dim Folder As String: Folder = xFd.SelectedItems(1) & "\"
Dim Files
Files = Dir(Folder & "*.xls*")
Dim Xls As String
On Error Resume Next
Dim CrWB As Workbook, CrSheet As Worksheet
Dim ClnW As New Collection, ClnC As New Collection
Dim Cols As Integer: Cols = 1
Do While Files <> ""
Xls = Replace(Folder & Files, "\\", "\")
Set CrWB = Application.Workbooks.Open(Xls, , True)
Set CrSheet = CrWB.Sheets("Sheet1")
If Err.Number > 0 Then
MsgBox "Can't open File " & Xls & vbCrLf & Err.Description
Err.Clear
GoTo 1
End If
Dim c As Range
Set ClnW = New Collection: Set ClnC = New Collection
For Each c In CrSheet.Range("A1:A1000")
If c.Value <> "" Then
Words = Split(CStr(c.Value), " ", , vbTextCompare)
For Each s In Words
Err.Clear
tmp = ClnW(s)
If Err.Number > 0 Then
ClnW.Add Item:=s, Key:=s
ClnC.Add Item:=1, Key:=s
Else
x = ClnC(s) + 1
ClnC.Remove s
ClnC.Add Item:=x, Key:=s
End If
Next
End If
Next
Set CrSheet = ThisWorkbook.Sheets("Sheet1")
With CrSheet
.Cells(1, Cols).Value = Files
.Cells(2, Cols).Value = "Word"
.Cells(2, Cols + 1).Value = "Occurance"
.Range(.Cells(1, Cols), .Cells(1, Cols + 1)).Merge
Dim I As Integer: I = 3
For Each s In ClnW
.Cells(I, Cols).Value = s
.Cells(I, Cols + 1).Value = ClnC(s)
I = I + 1
Next
End With
Cols = Cols + 2
1
CrWB.Close False
Files = Dir()
Err.Clear
Loop
End Sub
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)
I have a folder with a lot of subfolders, they're named based on a pattern with an iterating number in it for 98% of the folders.
I would like to find the highest number(name of sub folder,maxNumber =??) in it, how to do this?
numOfRows = maxFolder- 32020
'loops through each file in the directory and prints their names and path
'For Each objSubFolder In objFolder.subfolders to slow....
for pnr = 32020 to maxFolder
DoEvents
Call ProgressBar.setMessage("Updating for .." & pnr, ((i + 1) / (numOfRows + 1)) * 100)
You want to find subfolders with the highest number of what, exactly? This is probably a good place to get started.
http://www.learnexcelmacro.com/wp/download/
Here is the script.
Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)
'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No
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)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
'--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.
If Subfolders = True Then
For Each SubFolder In SourceFolder.Subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Finally, form the link above, you can download a sample file, named 'File Manager'; click 'Download Now' to get the file. That should do what you want.
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)