'Force the explicit delcaration of variablesOption Explicit
Sub ListFiles()
' from http://www.xl-central.com/list-the-files-in-a-folder-and-subfolders.html
' with heavy edits
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim last_row As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("File_listing")
last_row = Cells(Rows.Count, "A").End(xlUp).Row
ws.Range("A3:K" & last_row).ClearContents
'Insert the headers for Columns A through F
Range("A3").Value = "File Name"
Range("B3").Value = "File Size"
Range("C3").Value = "File Type"
Range("D3").Value = "Date Created"
Range("E3").Value = "Date Last Accessed"
Range("F3").Value = "Date Last Modified"
Range("G3").Value = "Path"
Range("H3").Value = "Hyperlink"
Range("i3").Value = "standard sheet A1"
Range("j3").Value = "Sheets"
Range("k3").Value = "full path"
ws.Range("A3:k3").Font.Bold = True
'Assign the top folder to a variable
strTopFolderName = ws.Range("B1").Value
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True, strTopFolderName)
'Change the width of the columns to achieve the best fit
Columns.AutoFit
ws.Columns("i:k").ColumnWidth = 40
Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
ws.PivotTables("Latest_versions").RefreshTable
ws.PivotTables("Latest_version_paths").RefreshTable
Call update_report_sheet
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean, strTopFolderName As String)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long
Dim pathfolder As String
Dim Record_wb As Workbook
Dim Record_ws As Worksheet
Dim Corrected_file_name As String
Dim wbFnd As Workbook
'Dim FileName As String
Dim wSheet As Worksheet
Dim all_sheets As String
'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files
'If Left(objFile.Name, 1) = "~" Then file_name = Right(objFile.Name, Len(objFile.Name) - 1) Else file_name = objFile.Name
'finds and removes the ~ from the start of any open files
Corrected_file_name = Replace(objFile.Name, "~$", "")
Cells(NextRow, "A").Value = Corrected_file_name 'was objfile.name
Cells(NextRow, "B").Value = objFile.Size
Cells(NextRow, "C").Value = objFile.Type
Cells(NextRow, "D").Value = objFile.DateCreated
Cells(NextRow, "E").Value = objFile.DateLastAccessed
Cells(NextRow, "F").Value = objFile.DateLastModified
Cells(NextRow, "k").Value = objFile.Path
pathfolder = Replace(objFile.Path, objFile.Name, "", , , vbTextCompare)
pathfolder = Replace(pathfolder, strTopFolderName, "", , , vbTextCompare)
Cells(NextRow, "G").Value = pathfolder
Cells(NextRow, "H").Value = "=HYPERLINK(""" & objFile.Path & """,""" & "Click Here to Open" & """)"
Cells(NextRow, "i").Value = "'" & strTopFolderName & pathfolder & "[" & objFile.Name & "]Summary_Report'!A2"
On Error Resume Next 'sets up the "if there's an error from attempting to open a file someone has opened skip"
Set wbFnd = Workbooks.Open(fileName:=objFile.Path, UpdateLinks:=False, ReadOnly:=True, Notify:=True)
If Err.Number <> 0 Then
all_sheets = "unable to display sheets as file open by someone else"
Else
For Each wSheet In ActiveWorkbook.Worksheets
If all_sheets = "" Then all_sheets = wSheet.Name Else all_sheets = all_sheets & "----" & wSheet.Name
Next
ActiveWorkbook.Close False
End If
Cells(NextRow, "j").Value = all_sheets
all_sheets = ""
NextRow = NextRow + 1
Next objFile
'Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True, strTopFolderName)
Next objSubFolder
End If
End Sub
Sub update_report_sheet()
Dim latest_version_list As Range
Dim source_ws As Worksheet
Dim wb As Workbook
Dim report_ws As Worksheet
Dim link As String
Dim last_file As Long, last_report_row As Long
Dim i As Integer
Dim Result_1 As String, Result_2 As String, Result_3 As String, Result_4 As String, Result_5 As String, Result_6 As String
Dim Result_6_no As Long
Dim result_7 As String
Dim convertor As Range
Dim file_name As String
Set wb = ActiveWorkbook
Set report_ws = wb.Sheets("Report Data")
Set source_ws = wb.Sheets("File_listing")
Set convertor = source_ws.Range("Sheet_2_fileName")
last_report_row = report_ws.Cells(Rows.Count, "A").End(xlUp).Row
report_ws.Range("A1:F" & last_report_row).ClearContents
last_file = source_ws.Cells(Rows.Count, "V").End(xlUp).Row
Set latest_version_list = source_ws.Range("v3,v" & last_file)
report_ws.Range("a1") = "Data Object"
report_ws.Range("b1") = "Source File Name"
report_ws.Range("c1") = "% progress"
report_ws.Range("d1") = "Data points over long"
report_ws.Range("e1") = "Total Data Points"
report_ws.Range("f1") = "Data points completed"
report_ws.Range("g1") = "% sheets manually closed"
report_ws.Range("h1") = "Hyperlink"
report_ws.Range("i1") = "extracted File Name"
report_ws.Range("A1:h1").Font.Bold = True
For i = 4 To last_file '4 as the data in the source listing starts on row 4
Result_1 = "='" & source_ws.Cells(i, "v").Value 'file name
Result_2 = Replace(Result_1, "A2", "g2") 'Data Object
Result_3 = Replace(Result_1, "A2", "i2") 'average progress
Result_4 = Replace(Result_1, "A2", "j2") 'cells over length
Result_5 = Replace(Result_1, "A2", "m2") 'total data points
Result_6 = Replace(Result_1, "A2", "n2") 'data points completed (calculated)
result_7 = Replace(Result_1, "A2", "o2") 'check for manual closure of object
file_name = WorksheetFunction.VLookup(source_ws.Cells(i, "v").Value, convertor, 3, False)
report_ws.Range("a" & i - 2).Value = Result_2 '-2 to adjust up to start at the top of the page
report_ws.Range("b" & i - 2).Value = Result_1
report_ws.Range("c" & i - 2).Value = Result_3
report_ws.Range("d" & i - 2).Value = Result_4
report_ws.Range("e" & i - 2).Value = Result_5
report_ws.Range("f" & i - 2).Value = Result_6
report_ws.Range("g" & i - 2).Value = result_7
report_ws.Range("h" & i - 2).Value = "=HYPERLINK(""" & file_name & """,""" & "Click Here to Open" & """)"
report_ws.Range("i" & i - 2).Value = "=MID(B" & i - 2 & ",FIND(""["",B" & i - 2 & ")+1,FIND(""]"",B" & i - 2 & ")-FIND(""["",B" & i - 2 & ")-1)"
Next i
report_ws.Range("C:C").NumberFormat = "#,#0.00%"
report_ws.Range("g:g").NumberFormat = "#,#0.00%"
report_ws.Range("D:F").NumberFormat = "#,###"
report_ws.Columns.AutoFit
End Sub