Using FileSystemObject to list files getting error - vba

I have Excel-2007. I am using File System Object VBA code to list files in a directory. I have also set up reference to Microsoft Scriptlet Library in excel.
I am getting:
Compiler error:User-defined type not defined
on this very first code line
Dim FSO As Scripting.FileSystemObject
Code used by me as follows:
Sub ListFilesinFolder()
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
SourceFolderName = "C:\mydir"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("text file", "path", "Date Last Modified")
i = 2
For Each FileItem In SourceFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
End Sub
Can someone point out where am I going wrong?
**UPDATE -03-09-2015**
I have updated my program based on #brettdj program and some research to list all files including sub-folder files. It works for me. I look forward to suggestions to further improve it.
Sub ListFilesinFolder()
Dim objFSO As Object
Dim ws As Worksheet
Dim cl As Range
Dim objFolderName As String
objFolderName = "C:\FY_2015-2016\sunil"
Set objFSO = New Scripting.FileSystemObject
Set ws = ActiveSheet
With Range("A1:C1")
.Value2 = Array("File", "path", "Date Last Modified")
.Font.Bold = True
End With
Set cl = ws.Cells(2, 1)
ListFolders cl, objFSO.GetFolder(objFolderName)
Set objFSO = Nothing
End Sub
Sub ListFolders(rng As Range, Fol As Scripting.Folder)
Dim SubFol As Scripting.Folder
Dim FileItem As Scripting.File
' List Files
For Each FileItem In Fol.Files
rng.Cells(1, 1) = FileItem.Name
rng.Cells(1, 2) = FileItem.ParentFolder.Path
rng.Cells(1, 3) = FileItem.DateLastModified
Set rng = rng.Offset(1, 0)
Next
' Proces subfolders
For Each SubFol In Fol.SubFolders
ListFolders rng, SubFol
Next
With ActiveSheet
.Columns.EntireColumn.AutoFit
End With
End Sub
I am posting another update which is not cell by cell filling.
REVISED UPDATE ON 3-09-2015
Sub GetFileList()
Dim strFolder As String
Dim objFSO As Object
Dim objFolder As Object
Dim myResults As Variant
Dim lCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
strFolder = .SelectedItems(1)
End With
Set objFolder = objFSO.GetFolder(strFolder)
'the variable dimension has to be the second one
ReDim myResults(0 To 5, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(1, 0) = "Size"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified"
myResults(4, 0) = "Accessed"
myResults(5, 0) = "Full path"
'Send the folder to the recursive function
FillFileList objFolder, myResults, lCount
' Dump these to a worksheet
fcnDumpToWorksheet myResults
'tidy up
Set objFSO = Nothing
End Sub
Private Sub FillFileList(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim objFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
'load the array with all the files
For Each objFile In objFolder.Files
lCount = lCount + 1
ReDim Preserve myResults(0 To 5, 0 To lCount)
myResults(0, lCount) = objFile.Name
myResults(1, lCount) = objFile.Size
myResults(2, lCount) = objFile.DateCreated
myResults(3, lCount) = objFile.DateLastModified
myResults(4, lCount) = objFile.DateLastAccessed
myResults(5, lCount) = objFile.Path
Next objFile
'recursively call this function with any subfolders
Set fsoSubFolders = objFolder.SubFolders
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
'since we switched the array dimensions, have to transpose
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub

Would recommend using an array approach for speed
Sub ListFilesinFolder()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim lngCnt As Long
Dim X
objFolderName = "C:\temp"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(objFolderName)
ReDim X(1 To objFolder.Files.Count, 1 To 3)
For Each objFile In objFolder.Files
lngCnt = lngCnt + 1
X(lngCnt, 1) = objFile.Name
X(lngCnt, 2) = objFile.Path
X(lngCnt, 3) = Format(objFile.DateLastModified, "dd-mmm-yyyy")
Next
[a2].Resize(UBound(X, 1), 3).Value2 = X
With Range("A1:C1")
.Value2 = Array("text file", "path", "Date Last Modified")
.Font.Bold = True
.Columns.EntireColumn.AutoFit
End With
End Sub

You're referencing Microsoft Scriptlet Library; should be Microsoft Scripting Runtime.

Try this:
Sub ListFilesinFolder()
Dim FSO
Dim SourceFolder
Dim FileItem
SourceFolderName = "C:\mydir"
Set FSO = CreateObject("Scripting.FileSystemObject") '<-- New change
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("text file", "path", "Date Last Modified")
i = 2
For Each FileItem In SourceFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
End Sub

Related

VBA: How to open most recent two excel files in the folder

I have trying to open the most recent two excel file in the folder so far i did open the latest file in folder but i have to open 2nd latest file in folder. refer below code. please suggest how to open 2nd most recent file?
Sub findingdiff()
Dim FileSys, objFile, myFolder, c As Object
Dim wb1 As Workbook
Dim wb2 As Workbook
FolderName = ("C:\Users\ashokkumar.d\Desktop\Test\do\")
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set myFolder = FileSys.GetFolder(FolderName)
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If InStr(1, objFile.Name, ".xls") > 0 Then
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
End If
Next objFile
'opening of latest file in the folder
Set wb2 = Workbooks.Open(FolderName & Application.PathSeparator & strFilename)
End Sub
Here's another way to tackle the problem. Create a sorted list and then process the first 2 files:
Sub Lastest2Files()
Dim rs As ADODB.Recordset
Dim fs As FileSystemObject
Dim Folder As Folder
Dim File As File
'create a recordset to store file info
Set rs = New ADODB.Recordset
rs.fields.Append "FileName", adVarChar, 100
rs.fields.Append "Modified", adDate
rs.Open
'build the list of files and sort
Set fs = New FileSystemObject
Set Folder = fs.GetFolder("C:\aatemp")
For Each File In Folder.Files
rs.AddNew
rs("FileName") = File.Path
rs("Modified") = File.DateLastModified
Next
rs.Sort = "Modified DESC"
'process the first 2 files
rs.MoveFirst
Set wb2 = Workbooks.Open(rs.fields("FileName").value)
rs.MoveNext
Set wb2 = Workbooks.Open(rs.fields("FileName").value)
End Sub
You can do it in one pass
Sub findingdiff()
Dim FileSys, objFile, myFolder, c As Object
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim strFilename, strFilename2
FolderName = ("C:\Users\ashokkumar.d\Desktop\Test\do\")
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set myFolder = FileSys.GetFolder(FolderName)
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If InStr(1, objFile.Name, ".xls") > 0 Then
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename2 = strFilename
strFilename = objFile.Name
End If
End If
Next objFile
'opening of latest file in the folder
Set wb1 = Workbooks.Open(FolderName & Application.PathSeparator & strFilename)
Set wb2 = Workbooks.Open(FolderName & Application.PathSeparator & strFilename2)
End Sub
I modified findingdiff when the first file it encounter is most recent; Otherwise findingdiff don't get the second most recent.
Hope this helps...
Private Sub SortDictionaryByKey() '220926
' http://www.xl-central.com/sort-a-dictionary-by-key.html
Dim ProcName As String: ProcName = Mod_Name & "SortDictionaryByKey" & Debug_Output_Seperator '220926
Debug.Print TimeStamp & ProcName
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim Dict As Scripting.Dictionary
Dim TempDict As Scripting.Dictionary
Dim KeyVal As Variant
Dim Arr() As Variant
Dim Temp As Variant
Dim Txt As String
Dim i As Long
Dim j As Long
'Create an instance of the Dictionary
Set Dict = New Dictionary
'Set the comparison mode to perform a textual comparison
Dict.CompareMode = TextCompare
Dim FileSys, objFile, myFolder, c As Object
Dim FolderName As Variant
Dim dteLatest As Variant
''''''''''''''''''''''''''''''''
FolderName = FolderSelect_Source_Destination '220922
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set myFolder = FileSys.GetFolder(FolderName)
With myFolder
End With
dteLatest = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
'220921
With objFile
If InStr(1, .name, PPT_Extension) > 0 Then
Dict.Add .DateLastModified, .Path
Debug.Print TimeStamp & ProcName & .Path
dteLatest = .DateLastModified
End If
End With
Next objFile
'Allocate storage space for the dynamic array
ReDim Arr(0 To Dict.Count - 1)
'Fill the array with the keys from the Dictionary
For i = 0 To Dict.Count - 1
Arr(i) = Dict.Keys(i)
Next i
'Sort the array using the bubble sort method
For i = LBound(Arr) To UBound(Arr) - 1
For j = i + 1 To UBound(Arr)
If Arr(i) > Arr(j) Then
Temp = Arr(j)
Arr(j) = Arr(i)
Arr(i) = Temp
End If
Next j
Next i
'Create an instance of the temporary Dictionary
Set TempDict = New Dictionary
'Add the keys and items to the temporary Dictionary,
'using the sorted keys from the array
For i = LBound(Arr) To UBound(Arr)
KeyVal = Arr(i)
TempDict.Add Key:=KeyVal, Item:=Dict.Item(KeyVal)
Next i
'Set the Dict object to the TempDict object
Set Dict = TempDict
'Build a list of keys and items from the original Dictionary
For i = 0 To Dict.Count - 1
Txt = Txt & Dict.Keys(i) & vbTab & Dict.Items(i) & vbCrLf
Next i
With Dict
str_Recent_FileFullName(1) = .Items(.Count - 1)
str_Recent_FileFullName(2) = .Items(.Count - 2)
Stop
'Display the list in a message box
End With
MsgBox Txt, vbInformation
Set Dict = Nothing
Set TempDict = Nothing
Set KeyVal = Nothing
Erase Arr()
Set Temp = Nothing
Set FileSys = Nothing
End Sub

How to import in excel the path of the last file saved?

i want to import the whole path of the file C:\Users\fld but just the recent files in today for example .
Can you help me please ?
below my vba to import the path:
Sub test()
Dim fso As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oFolder As Scripting.Folder
Dim strFolderName As String
Dim i As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Cells(1, 1).Value = "fld"
strFolderName= "C:\Users\fld"
i = 2
Range("A2").Select
ActiveCell = Range("A2")
Set oSourceFolder = fso.GetFolder(strFolderName)
For Each oFolder In oSourceFolder.SubFolders
For Each oFile In oFolder.Files
Cells(i, 1).Value = Left(oFile.ParentFolder)
i = i + 1
Next oFile
Next oFolder
Try this :
Sub test()
Dim fso As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oFolder As Scripting.Folder
Dim strFolderName As String
Dim i As Long
Set fso = CreateObject("Scripting.FileSystemObject")
strFolderName = "C:\Users\fld"
i = 2
Range("A2").Select
ActiveCell = Range("A2")
Dim dt As Date
Dim pathLastUpdatePath As String
'Find last Date of file----------------------------------------'
'Find file that have last DateTime Update in parent folder
Set oFolder = fso.GetFolder(strFolderName)
For Each oFile In oFolder.Files
fileModDate = oFile.DateLastModified
If fileModDate > dt Then
dt = fileModDate
pathLastUpdatePath = oFile.Path
End If
Next oFile
'Find file that have last DateTime Update in Sub folders
Set oSourceFolder = fso.GetFolder(strFolderName)
For Each subFolder In oSourceFolder.SubFolders
For Each sFile In subFolder.Files
fileModDate = sFile.DateLastModified
If fileModDate > dt Then
dt = fileModDate
pathLastUpdatePath = sFile.Path
End If
Next sFile
Next subFolder
'Find and Show all files are modified in the same day----------------------'
Cells(1, 1).Value = "File with DateLastModified"
Cells(1, 2).Value = "DateTime File"
Set oFolder = fso.GetFolder(strFolderName)
For Each oFile In oFolder.Files
fileModDate = oFile.DateLastModified
If DateValue(fileModDate) = DateValue(dt) Then
Cells(i, 1).Value = oFile.Path
Cells(i, 2).Value = fileModDate
i = i + 1
End If
Next oFile
Set oSourceFolder = fso.GetFolder(strFolderName)
For Each subFolder In oSourceFolder.SubFolders
For Each sFile In subFolder.Files
fileModDate = sFile.DateLastModified
If DateValue(fileModDate) = DateValue(dt) Then
Cells(i, 1).Value = sFile.Path
Cells(i, 2).Value = fileModDate
i = i + 1
End If
Next sFile
Next subFolder
End Sub

Excel VBA List Files in Folder with Owner/Author Properties

This works, but is painfully slow:
Option Explicit
Sub GetDetails()
Dim oShell As Object
Dim oFile As Object
Dim oFldr As Object
Dim lRow As Long
Dim iCol As Integer
Dim vArray As Variant
vArray = Array(0, 3, 10, 20)
Set oShell = CreateObject("Shell.Application")
lRow = 1
Set oFldr = oShell.Namespace("\\mysite\www\docs\f150\group\IDL\collection\")
With oFldr
For iCol = LBound(vArray) To UBound(vArray)
Cells(lRow, iCol + 1) = .getdetailsof(.items, vArray(iCol))
Next iCol
For Each oFile In .items
lRow = lRow + 1
For iCol = LBound(vArray) To UBound(vArray)
On Error Resume Next
Cells(lRow, iCol + 1) = .getdetailsof(oFile, vArray(iCol))
Next iCol
Next oFile
End With
End Sub
I have the code below working, but I still cant get the Owner/Author or the specific file types.
Sub getFiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("\\mysite\www\docs\f150\group\IDL\collection")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
With Cells(i + 1, 1)
Cells(i + 1, 1).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path
End With
'print file path
Cells(i + 1, 2) = objFile.DateLastModified
i = i + 1
Next objFile
Columns.AutoFit
End Sub
I am trying to get a list of certain files and attributes into an Excel document, but the code keeps causing Excel to crash.
The code below may have some redundancy because I've been fiddling with it all day. Ultimately I would like to get the .pptx and .pdf file names, DateLastModified, and the owner or author
Sub ListAllFile()
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFolderItem As Object
Dim objFile As Object
Dim ws As Worksheet
Dim myExt1 As String
Dim myExt2 As String
myExt1 = "*.pptx"
myExt2 = "*.pdf"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = Worksheets.Add
'Get the folder object associated with the directory
Set objFolder = objFSO.GetFolder("\\mysite\www\docs\f150\group\IDL\collection")
ws.Cells(1, 1).Value = "The current files found in " & objFolder.Name & "are:"
Set objFile = objFile
'Loop through the Files collection
For Each objFile In objFolder.Files
If StrComp(objFile.Name, myExt1) = 1 Or StrComp(objFile.Name, myExt2) = 1 Then
Dim strFilePath As Object
Dim arrHeaders(35)
Dim i As Integer
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("\\mysite\www\docs\f150\group\IDL\collection")
Set objFileName = objFolder.ParseName(objFile.Name)
For Each objFile In objFolder.Items
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
ws.Cells(ws.UsedRange.Rows.Count + 0, 2).Value = objFile.DateLastModified
'This returns the "Owner" as the value for every file (not what I want)
ws.Cells(ws.UsedRange.Rows.Count + 0, 3).Value = objFolder.GetDetailsOf(objFile, 10)
'This returns the "Author" as the value for every file (not what I want)
ws.Cells(ws.UsedRange.Rows.Count + 0, 4).Value = objFolder.GetDetailsOf(objFile, 20)
'This returns the actual owner
ws.Cells(ws.UsedRange.Rows.Count + 0, 5).Value = objFolder.GetDetailsOf(strFileName, 10)
'This returns the actual author
ws.Cells(ws.UsedRange.Rows.Count + 0, 6).Value = objFolder.GetDetailsOf(strFileName, 20)
Next
End If
Next
Columns.AutoFit
'Clean up
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set objShell = Nothing
Set objFileName = Nothing
Set ws = Nothing
Application.ScreenUpdating = True
End Sub
I changed the second for each loop variable name to objfile1 and made appropriate modifications below it:
For Each objfile1 In objFolder.Items
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objfile1.Name
ws.Cells(ws.UsedRange.Rows.Count + 0, 2).Value = objFile.DateLastModified
Note that DateLastModified is a property of objFile while Name belongs to objfile1.
Hope this helps.
You could try and use the CMD.exe DIR command to optimize it a bit, as well as a couple of other tweaks:
Sub Foo()
Dim myExt1 As String
Dim myExt2 As String
Dim searchFolder As Variant
Dim finalArray As Object
Dim shellObj As Object
searchFolder = "\\mysite\www\docs\f150\group\IDL\collection"
myExt1 = "*.pptx"
myExt2 = "*.pdf"
Set finalArray = CreateObject("System.Collections.ArrayList")
Set shellObj = CreateObject("Shell.Application").Namespace(searchFolder)
For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR " & searchFolder & "\" & myExt1 & " /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
finalArray.Add CStr(file)
Next
For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR " & searchFolder & "\" & myExt2 & " /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
finalArray.Add CStr(file)
Next
For Each file In finalArray.ToArray()
With Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
.Value = CStr(file)
.Offset(0, 1).Value = shellObj.GetDetailsOf(CStr(file), 10)
.Offset(0, 2).Value = shellObj.GetDetailsOf(CStr(file), 20)
End With
Next
End Sub

Excel VBA: Create list of subfolders and files within source folder

I am using the following code to list all files in a host folder and it's sub folders. The code works great but, do you know how I can update the code to also list some the file attributes.
Sub file_list()
Call ListFilesInFolder("W:\ISO 9001\INTEGRATED_PLANNING\", True)
End Sub
Sub ListFilesInFolder(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 r As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.getFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Name
r = r + 1
X = SourceFolder.Path
Next FileItem
If IncludeSubfolders 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
Function GetFileOwner(ByVal FilePath As String, ByVal FileName As String)
Dim objFolder As Object
Dim objFolderItem As Object
Dim objShell As Object
FileName = StrConv(FileName, vbUnicode)
FilePath = StrConv(FilePath, vbUnicode)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
End If
If Not objFolderItem Is Nothing Then
GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 8)
Else
GetFileOwner = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
What I would really like to see is;
Column A = Host folder/subfolder
Column B = File name
Column C = hyperlink to file
Is this possible?
I do have a code that created hyperlinks but, I do not know how to add to the existing code.
Sub startIt()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "W:\ISO 9001\INTEGRATED_PLANNING\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.Subfolders
DoFolder SubFolder
Next
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim File
For Each File In Folder.Files
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:= _
File.Path, TextToDisplay:=File.Name
i = i + 1
Next
End Sub
You can see the list of properties that the File Object supports here: https://msdn.microsoft.com/en-us/library/1ft05taf(v=vs.84).aspx
So you can enhance your code, where it is taking the .Name property and putting that in a cell formula, to do something similar with other properties, such as the .Type of the file.
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Name
Cells(r, 2).Value = FileItem.Type
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 3), Address:= _
FileItem.Path, TextToDisplay:=FileItem.Name
r = r + 1
X = SourceFolder.Path
Next FileItem
n.b. I've used Value instead of Formula, but in this case the result will be the same.
In a similar manner, you can add another Cells(r, 3).Value = line to set the value of cell in the current row r and column 3 to whatever your hyperlink is.
I wrote a little script for this purpose to my colleague for a time ago...
See my code below:
Sub FolderNames()
'Written by Daniel Elmnas Last update 2016-02-17
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Subfolder", "Hostfolder", "Filename", "Date Created", "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "\")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld
End Sub
Here is the result:
You can modify it a bit though.
If you example dont want to use a window-dialog and instead use
"W:\ISO 9001\INTEGRATED_PLANNING\"
Cheers!

Find file and insert path into cell

I have a file name of a pdf that I want to search for in a folder on a shared network drive \\Share\Projects. The pdf will be in one of the subfolders under projects. I then want to return the entire file path of the pdf into a cell (eg \\Share\Projects\Subfolder\Another subfolder\thisone.pdf).
I have started the code but can't figure out how to search a file system:
Sub InsertPath()
Dim PONumber As String
PONumber = InputBox("PO Number:", "PO Number")
'search for order
Dim myFolder As Folder
Dim myFile As File
'This bit doesn't work
Set myFolder = "\\Share\Projects"
For Each myFile In myFolder.Files
If myFile.Name = "PO" & PONumber & ".pdf" Then
'I have absolutely no idea how to do this bit
End If
Next
End Sub
Am I on the right track or is my code completely wrong?
get list of subdirs in vba
slighly modified the above post.
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim i As Long
Dim j As Long
Dim MyFile As String
Const strPath As String = "C:\Personal\" ' change it as per your needs
myArr = GetSubFolders(strPath)
Application.ScreenUpdating = False
Range("A1:B1") = Array("text file", "path")
For j = LBound(Arr) To UBound(Arr)
MyFile = Dir(myArr(j) & "\*.pdf")
Do While Len(MyFile) <> 0
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = myArr(j)
MyFile = Dir
Loop
Next j
Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
Counter = Counter + 1
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
Well, your folder declaration isn't set against a filesystemobject so it can't find the folder. And because it's a network location, you may need to map a network drive first so that it's a secure link.
So here's an updated version of your code.
EDIT - to OP's conditions.
Dim PONumber As String
Sub InsertPath()
PONumber = InputBox("PO Number:", "PO Number")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Servershare As String
ServerShare = "S:\"
Dim Directory As Object
Set Directory = fso.GetFolder(ServerShare)
Subfolderstructure Directory
End Sub
Function Subfolderstructure(Directory As Object)
For Each oFldr in Directory.SubFolders
For Each FileName In oFldr.Files
If FileName.Name = "PO" & PONumber & ".pdf" Then
sheets("Sheet1").range("A1").value = ServerShare & "\PO" & PONumber & ".pdf"
Exit For
End If
Next
Dim sbfldrs : Set sbfldrs = ofldr.SubFolders
If isarray(sbfldrs) then
Subfolderstructure ofldr
End if
Next
'Cleanup
Set FileName = Nothing
Set Directory = Nothing
Set fso = Nothing
End Function
I have not tested this code. Try it out and let me know how it works.