I have two VBA codes. One loops through and prints the file properties, and the other grabs the owner of a file.
How do I merge the File Owner VBA code into File Properties to print the file name, modification date and owner onto a sheet?
File Properties - VBA
Sub MainList()
Application.ScreenUpdating = True
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
Application.ScreenUpdating = False
End Sub
Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Application.ScreenUpdating = True
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Path
Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Name
Application.ActiveSheet.Cells(rowIndex, 3).Formula = xFile.DateLastAccessed
Application.ActiveSheet.Cells(rowIndex, 4).Formula = xFile.DateLastModified
Application.ActiveSheet.Cells(rowIndex, 5).Formula = xFile.DateCreated
Application.ActiveSheet.Cells(rowIndex, 6).Formula = xFile.Type
Application.ActiveSheet.Cells(rowIndex, 7).Formula = xFile.Size
Application.ActiveSheet.Cells(rowIndex, 8).Formula = xFile.Owner
ActiveSheet.Cells(2, 9).FormulaR1C1 = "=COUNTA(C[-7])"
rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
For Each xSubFolder In xFolder.SubFolders
ListFilesInFolder xSubFolder.Path, True
Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
Application.ScreenUpdating = False
End Sub
File Owner - VBA
Sub test()
Dim fName As String
Dim fDir As String
fName = "FileName.JPG"
fDir = "C:/FilePath"
Range("A1").Value = GetFileOwner(fDir, fName)
End Sub
Function GetFileOwner(fileDir As String, fileName As String) As String
Dim securityUtility As Object
Dim securityDescriptor As Object
Set securityUtility = CreateObject("ADsSecurityUtility")
Set securityDescriptor = securityUtility.GetSecurityDescriptor(fileDir & fileName, 1, 1)
GetFileOwner = securityDescriptor.Owner
End Function
Without refactoring it, if you change this line of code;
Application.ActiveSheet.Cells(rowIndex, 8).Formula = xFile.Owner
To this;
Application.ActiveSheet.Cells(rowIndex, 8).Formula = GetFileOwner(xFolderName, xFile.Name)
It will call the GetFileOwner function and should do the trick for you.
Related
I want to get subfolders name with files name through Excel VBA.
What I really want is Column A shows subfolders name, Column B shows files name.
Here is my code:
Option Explicit
Private xRow As Long
Sub Get_MAIN_File_Names()
Dim fso As FileSystemObject
Dim xDirect As String
Dim xRootFolder As Folder
Dim DrawingNumb As String
Dim RevNumb As String
Dim rootFolderStr As String
Set fso = New FileSystemObject
xRow = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Main File"
.Show
'PROCESS ROOT FOLDER
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
Set xRootFolder = fso.GetFolder(xDirect)
ProcessFolder fso, xRootFolder
End If
End With
End Sub
Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
Dim xFiles As Files
Dim xFile As File
Dim xSubFolders As Folders
Dim xSubFolder As Folder
Dim xSubFolderName As String
Dim xFileName As String
Dim xFileTime As String
Set xFiles = xFolder.Files
'Adding Column names
Cells(1, "A").Value = "SubFolder Name"
Cells(1, "B").Value = "File Name"
Cells(1, "C").Value = "Modified Date/Time"
For Each xSubFolder In xSubFolders
xSubFolderName = xSubFolder.Name
ActiveCell.Offset(xRow, 0) = xSubFolderName
xRow = xRow + 1
Next xSubFolder
'LOOPS THROUGH EACH FILE NAME IN FOLDER
For Each xFile In xFiles
'EXTRACT INFORMATION FROM FILE NAME
xFileName = xFile.Name
xFileTime = xFile.DateLastModified
'INSERT INFO INTO EXCEL
ActiveCell.Offset(xRow, 1) = xFileName
ActiveCell.Offset(xRow, 2) = xFileTime
xRow = xRow + 1
Next xFile
Set xSubFolders = xFolder.SubFolders
For Each xSubFolder In xSubFolders
ProcessFolder fso, xSubFolder
Next xSubFolder
End Sub
However, I don't get what I want. I think the problem is here:
For Each xSubFolder In xSubFolders
xSubFolderName = xSubFolder.Name
ActiveCell.Offset(xRow, 0) = xSubFolderName
xRow = xRow + 1
Next xSubFolder
Which part do I ignore? Or is there another way to solve?
I think the code is too long. Maybe inefficient. How to modify the code?
Your entire
For Each xSubFolder In xSubFolders
xSubFolderName = xSubFolder.Name
ActiveCell.Offset(xRow, 0) = xSubFolderName
xRow = xRow + 1
Next xSubFolder
section is going to fail because you haven't defined xSubFolders at that point. Even if it didn't fail, it wouldn't do what you wanted because it would be moving the writing of the subfolder name away from the rows where you are writing the file details.
To resolve your issue you should delete that section and simply write the folder name out at the same time as you write the file details:
Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
Dim xFiles As Files
Dim xFile As File
Dim xSubFolders As Folders
Dim xSubFolder As Folder
Dim xFileName As String
Dim xFileTime As String
Set xFiles = xFolder.Files
Set xSubFolders = xFolder.SubFolders
'Adding Column names
'This should really be done once in the main procedure, rather than being performed
'for every folder processed, but is simply overwriting the information written
'last time through so will be inefficient but not incorrect.
Cells(1, "A").Value = "SubFolder Name"
Cells(1, "B").Value = "File Name"
Cells(1, "C").Value = "Modified Date/Time"
'LOOPS THROUGH EACH FILE NAME IN FOLDER
For Each xFile In xFiles
'EXTRACT INFORMATION FROM FILE NAME
xFileName = xFile.Name
xFileTime = xFile.DateLastModified
'INSERT INFO INTO EXCEL
ActiveCell.Offset(xRow, 0) = xFolder.Name
ActiveCell.Offset(xRow, 1) = xFileName
ActiveCell.Offset(xRow, 2) = xFileTime
xRow = xRow + 1
Next xFile
Set xSubFolders = xFolder.SubFolders
For Each xSubFolder In xSubFolders
ProcessFolder fso, xSubFolder
Next xSubFolder
End Sub
Try this version.
Sub TestListFolders()
Application.ScreenUpdating = False
'create a new workbook for the folder list
'commented out by dr
'Workbooks.Add
'line added by dr to clear old data
Cells.Delete
' add headers
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "Folder Name:"
Range("C3").Formula = "Size:"
Range("D3").Formula = "Subfolders:"
Range("E3").Formula = "Files:"
Range("F3").Formula = "Short Name:"
Range("G3").Formula = "Short Path:"
Range("A3:G3").Font.Bold = True
'ENTER START FOLDER HERE
' and include subfolders (true/false)
ListFolders "C:\Users\Excel\Desktop\Coding\Microsoft Excel\Work Samples\Finance\", True
Application.ScreenUpdating = True
End Sub
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
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'line added by dr for repeated "Permission Denied" errors
On Error Resume Next
' display folder properties
r = Range("A65536").End(xlUp).Row + 1
Cells(r, 1).Formula = SourceFolder.Path
Cells(r, 2).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
Next SubFolder
Set SubFolder = Nothing
End If
Columns("A:G").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
'commented out by dr
'ActiveWorkbook.Saved = True
End Sub
As an alternative, you can download the sample file from the link below (click 'Download Now'). That Macro will do a nice job for you.
http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/
The code you provided is unlikely to work for a number of reasons, have a look at the changes below, which might help:
Private Sub ProcessFolder(FSO as FileSystemObject, xFolder As Folder)
Dim xFile as File
Dim CurRow As Integer
'Your original code was going to wipe over the data when you got to each new SubFolder. This should prevent that:
For CurRow = 1 to 100000
If Range("A" & CurRow).Value = "" And Range("B" & CurRow).Value = "" Then Exit For
Next CurRow
If CurRow = 1 then
Range("A1").Value = "Sub Folder Name"
Range("B1").Value = "File Name"
Range("C1").Value = "Modified Date/Time"
CurRow = CurRow + 1
End If
Range("A" & CurRow).Value = xFolder.Name
CurRow = CurRow + 1
For Each xFile in xFolder.Files
Range("B" & CurRow).Value = xFile.Name
Range("C" & CurRow).Value = xFile.DateLastModified
CurRow = CurRow + 1
Next xFile
End Sub
I have below code which prints text from a column but open a text file many times instead of once. Please let me know what is the wrong.
When I run sub in Visual Basic debug mode, it open text file only once. But I am calling this macro after another macro and that time it is opening (same) text file many times.
Sub createdevtest()
Dim filename As String, lineText As String
Dim data As Range
Dim myrng As Range, i, j
' filename = ThisWorkbook.Path & "\textfile-" & Format(Now, "ddmmyy-hhmmss") & ".txt"
filename = ThisWorkbook.Path & "\devtest" & ".txt"
Open filename For Output As #1
Dim LastRow As Long
'Find the last non-blank cell in column A(1)
LastRow = Cells(Rows.count, 1).End(xlUp).Row
Range("B4:B" & LastRow).Select
Set myrng = Selection
For i = 1 To myrng.Rows.count
For j = 1 To myrng.Columns.count
lineText = IIf(j = 1, "", lineText & ",") & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
Range("B4").Select
' open devtest
'Shell "explorer.exe" & " " & ThisWorkbook.Path, vbNormalFocus
filename = Shell("Notepad.exe " & filename, vbNormalFocus)
End Sub
Thanks #Luuklag. I had tried to figure out on my own but no success. After your comment, just went thru code again and got clue.
Below is the correct code where I have called one of the macro (devtest1) which contains above text file creation macro (createdevtest). Before correction I was calling macro in function instead of Sub, so it was looping again and opening txt file many times.
' macro to select folder and list files
Sub GetFileNames_devtest()
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
' call devtest: corrected to call macro at right place
devtest1
End Sub
Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
For Each xSubFolder In xFolder.SubFolders
ListFilesInFolder xSubFolder.Path, True
Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
'' Was calling wrongly macro here
End Sub
Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function
End Function
I am trying to list all the files from a folder and subfolder(s) based on a string from a userform into a new workbook. For eg. I am want to input the string as 0200-T1;0201-T12 and I am splitting the string using ";" to search for two or more files which begin with the respective strings. Please have a look at my code and suggest corrections. Currently it only lists the first string from the split array.
Sub ListFilesHomolog()
xdir = Usrfrm_JbOrderFiles.Txtbx_Browse2.Value ' define search path
Set mywb = Workbooks.Add
Call ListFilesInFolderHomolog(xdir, True)
End Sub
Sub ListFilesInFolderHomolog(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Application.ScreenUpdating = False
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
On Error GoTo 0
rowIndex = Application.ActiveSheet.Range("A1048576").End(xlUp).Row + 1
For Each xFile In xFolder.Files
On Error Resume Next
fname = xFile.Name
HomFiles = Split(Usrfrm_JbOrderFiles.txtbx_jbOrdNo2.Value, ";")
For scount = LBound(HomFiles) To UBound(HomFiles)
srchTrm = HomFiles(scount) 'value from form
tst = Split(fname, "-")
If InStr(UCase(tst(0) & "-" & tst(1)), UCase(srchTrm)) = 0 Then GoTo a: 'skip if string not found
With mywb
mywb.Activate
Worksheets(1).Columns("A:H").FormatConditions.Add Type:=xlExpression, Formula1:="=E($A1<>"""";MOD(LIN();2))"
Worksheets(1).Columns("A:H").FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Worksheets(1).Columns("A:H").FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
End With
Worksheets(1).Columns("A:H").FormatConditions(1).StopIfTrue = False
Worksheets(1).Cells(1, 1).Value = "File Name" 'file name"
Worksheets(1).Cells(1, 8).Value = "Link" 'file name"
Worksheets(1).Cells(rowIndex, 1).Formula = xFile.Name 'file name
ActiveSheet.Hyperlinks.Add Cells(rowIndex, 8), xFile, TextToDisplay:="Open"
Worksheets(1).Cells.EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
End With
rowIndex = rowIndex + 1
Next scount
a:
Next xFile
If xIsSubfolders Then
For Each xSubFolder In xFolder.SubFolders
ListFilesInFolderHomolog xSubFolder.Path, True
Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
Application.ScreenUpdating = True
End Sub
You currently exit from your For scount loop if the file being looked at does not match the first criteria.
Using your example criteria of "0200-T1;0201-T12", if the filename does not contain the string "0200-T1" you exit the loop and never check to see if the filename contains the string "0201-T12".
You need to change
Next scount
a:
Next xFile
to be
a:
Next scount
Next xFile
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!
Given a folder tree:
c:\example\
c:\example\2014-01-01\
c:\example\2014-01-01\Entered\
c:\example\2014-01-02\
c:\example\2014-01-02\Entered
etc.
I want to count the PDF files in the tree, but excluding any in the "Entered\" subfolders.
Is this possible even with VBA? Ultimately this count needs to be spit out onto an excel sheet.
copy all the code in an Excel-VBA Module. If you want to use a button then you should use CntFiles() on the button. But if you don't want to use a button then you can use fCount(strPath) as a formula on the Worksheet i.e =fCount("your-path"), the parameter is String so make it double-quoted when using on Worksheet.
Function fCount(strPath)
Dim fCnt As Integer
fCnt = ShowFolderList(strPath)
fCount = fCnt
End Function
Sub CntFiles()
Dim strPath As String
strPath = "A:\Asif\Answers\abc"
ShowFolderList (strPath)
End Sub
Function ShowFolderList(Path)
Dim fso, folder, subFlds, fld
Dim tFiles As Integer
tFiles = ShowFilesList(Path)
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(Path)
Set subFlds = folder.SubFolders
For Each fld In subFlds
If fld.Name = "Entered" Then
GoTo SkipFld:
Else
Path = fld.Path
tFiles = tFiles + ShowFilesList(Path)
End If
SkipFld:
Next
'MsgBox tFiles & " files"
ShowFolderList = tFiles
End Function
Function ShowFilesList(folderspec)
Dim fso, f, f1, fc, s
Dim Cnt As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
If GetAnExtension(f1) = "pdf" Then
Cnt = Cnt + 1
Else
End If
Next
ShowFilesList = Cnt
End Function
Function GetAnExtension(DriveSpec)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
GetAnExtension = fso.GetExtensionName(DriveSpec)
End Function
This code will count all the files in the specified folder as well as sub-folders excluding folder named "Entered" as you specified.
This code gives you a nice overview in an excel sheet:
Sub start()
Application.ScreenUpdating = False
Dim FolderName As String
Sheets("fldr").Select
Cells(1, 1).Value = 2
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
ListFolders (FolderName)
Application.ScreenUpdating = True
MsgBox "Done" & vbCrLf & "Total files found: " & Cells(1, 1).Value
Cells(1, 1).Value = "Source"
Cells(1, 2).Value = "Folder"
Cells(1, 3).Value = "Subfolder"
Cells(1, 4).Value = "FileCount"
End Sub
Sub ListFolders(Fldr As String)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Dim fl1
Set fl1 = CreateObject("Scripting.FileSystemObject")
Dim fl2
Set fl2 = CreateObject("Scripting.FileSystemObject")
Set fl1 = fs.GetFolder(Fldr)
For Each fl2 In fl1.SubFolders
Cells(Cells(1, 1).Value, 1).Value = Replace(Fldr, fl1.Name, "")
Cells(Cells(1, 1).Value, 2).Value = fl1.Name
Cells(Cells(1, 1).Value, 3).Value = fl2.Name
Cells(Cells(1, 1).Value, 4).Value = CountFiles(Fldr & "\" & fl2.Name)
Cells(1, 1).Value = Cells(1, 1).Value + 1
ListFolders fl2.Path
Next
End Sub
Function CountFiles(Fldr As String)
Dim fso As Object
Dim objFiles As Object
Dim obj As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(Fldr).Files
CountFiles = objFiles.Count
Set objFiles = Nothing
Set fso = Nothing
Set obj = Nothing
End Function