I've been trying to edit a bit of code which gives a list of all files in all subfolders to also give me the date created in the next column but am unsure how. Here is the code i'm working with: It gets the file paths fine but not the file DateCreateds
Sub startIt()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\folderthing"
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.Path
ActiveSheet.Add TextToDisplay:=File.DateCreated
i = i + 1
Next
End Sub
If you want the Date in column B, then:
Sub startIt()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\TestFolder"
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.Path
Cells(i, 2).Value = File.DateCreated
i = i + 1
Next
End Sub
Related
I'm using this code, but I'm trying to change it to get a list of folder paths. The code looks in the directory for the name of the folder of the entered text in cells C and D, but there is no cyclicity when returning the result.
Sub GetPath()
Dim searchFolderName As String
searchFolderName = "D:\"
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
doFolder FileSystem.GetFolder(searchFolderName)
End Sub
Sub doFolder(folder)
Dim subFolder
Dim myLastRow As Long, myRow As Long
myLastRow = Cells(Rows.Count, "C").End(xlUp).Row
On Error Resume Next
For myRow = 3 To myLastRow
If Cells(myRow, "C") = "" Then
On Error Resume Next
End If
FolderName = "P_BNB_" & Cells(myRow, "C") & "_" & Cells(myRow, "D")
For Each subFolder In folder.subfolders
If Split(subFolder, "\")(UBound(Split(subFolder, "\"))) = FolderName Then
Sheets("Create Folders").Cells(myRow, "E") = subFolder
End
End If
doFolder subFolder
Next subFolder
Next myRow
End Sub
I've tried and search through out vba forum to figure out how can I rectify my code (below) to search files within a specific directory and its sub-directories to list and populated list of file that have 20 characters in filename length and just only pdf extension.
I want to list of file with no extension at the end in column A and full file path and name in column B.
Also tried to sort all files ascending after list created but no success yet :(
any help? Thanks
Sub ListPDF()
Range("A:L").ClearContents
Range("A1").Select
Dim strPath As String
strPath = "K:\Test\PDF\"
Dim OBJ As Object, Folder As Object, File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)
Call ListFiles(Folder)
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
Call ListFiles(SubFolder)
Call GetSubFolders(SubFolder)
Next SubFolder
Range("A1").Select
End Sub
Sub ListFiles(ByRef Folder As Object)
For Each File In Folder.Files
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0) = File.Name
ActiveCell.Offset(0, 1) = File.Path
Next File
End Sub
Sub GetSubFolders(ByRef SubFolder As Object)
Dim FolderItem As Object
For Each FolderItem In SubFolder.Subfolders
Call ListFiles(FolderItem)
Call GetSubFolders(FolderItem)
Next FolderItem
End Sub
Use this:
Option Explicit
Dim fso As Object, fsoFolder As Object, fsoSubFolder As Object, fsoFile As Object
Public Sub ListPDFs()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.UsedRange.ClearContents
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
ShowPDFs ThisWorkbook.Path & "\..", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Public Sub ShowPDFs(ByRef fsoPath As String, ByRef ws As Worksheet)
Dim lastCell As Range, pdfName As String
Set fsoFolder = fso.GetFolder(fsoPath)
For Each fsoFile In fsoFolder.Files
pdfName = fsoFile.Name
If Len(pdfName) > 20 Then
If InStr(1, pdfName, ".pdf") > 0 Then
pdfName = Left(pdfName, InStrRev(pdfName, ".") - 1)
Set lastCell = ws.Cells(ws.Rows.Count, 1).End(xlUp)
lastCell.Offset(1, 0) = pdfName
lastCell.Offset(1, 1) = fsoFile.Path
End If
End If
Next
For Each fsoSubFolder In fsoFolder.SubFolders
ShowPDFs fsoSubFolder.Path, ws
Next
End Sub
I have been trying to write a macro that will list the sheet names of every workbook in my directory. These files are stored in various folders and subfolders, so I would like for it to pull out everything and I can extrapolate the information I need from the whole output. This code is something I've put together with the help of users from this site, but I still am not getting the desired result. Someone please help!
Sub machinegun()
FileType = "*.xls*"
OutputRow = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("G:")
Set Curr_File = (filepath & FileType)
For Each Subfolder In Folder.Subfolders
Do Until Curr_File = ""
Set Fldr.wkbk = Workbooks.Open(filepath & Curr_File, False, True)
ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = Curr_File
ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents
OutputRow = OutputRow + 1
For Each Sht In FldrWkbk.Sheets
ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Sht.Name
ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents
OutputRow = OutputRow + 1
Next Sht
FldrWkbk.Close SaveChanges:=False
Loop
Next
End Sub
Here is something from Loop Through All Subfolders Using VBA, that would work for you:
Option Explicit
Sub LoopThroughFiles()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\Users\"
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
Dim File
For Each File In Folder.Files
Debug.Print File.name
Next
End Sub
Just make sure that you run LoopThroughFiles() and change the HostFolder to something meaningful. Then work with File.name in the debug.print.
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!
I want to get Names of Folders from a Directory and Names of Any Subfolders from that Directory Upto 2 Levels.
So It's Main Dir -> Folder Name -> SubFolder1 -> SubFolder2
The code below gets all the Folders and Subfolders Name.I got the code from here . Any idea how can I limit to just two subfolders only ?
Option Explicit
Sub FolderNames()
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("Path", "Dir", "Name", "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
getSubFolder is implemented a little bit strange ... but you can simply add a second parameter - let's call it Level as integer to it. When calling the procedure from the Main Dir you can set it to 0. In the recursiv call within the procedure you add always 1 to it before you pass it. So you know always at which level you are
Sub getSubFolder(ByRef prntfld As Object, ByVal Level As Integer)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
Level = Level + 1
If Level >= 3 Then Exit Sub
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)
getSubFolder SubFolder, Level
Next SubFolder
End Sub
haven't tested, but should work.
here the same code with the If statement inside the loop:
Sub getSubFolder(ByRef prntfld As Object, ByVal Level As Integer)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
Level = Level + 1
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)
If Level <= 2 Then getSubFolder SubFolder, Level
Next SubFolder
End Sub
The result should be the same.
I came across a similar issue whereby I wanted to stop looping through other subfolder once I got the folder I wanted using the FolderExists function. However as I used a For loop to loop through subfolders of FileSystemObject and as VBA does not allow you to get out of the For loop like you do to a While loop, I used Exit Sub statement after returning the desired sub folder by using the = retval statement format.