Sluggish Script when accessing Last Author

I tried to do this in a batch file but could only get the owner field as Windows/DOS does not store last modified by.

I turned to chatgpt to get help on this and ended up with a script that would give: last modified date, filename but not the last modified by (last author).

I found someone in the company that could get me that last field but the script runs slow as molasses.

Note: Originally tried on a OneDrive/Teams folder. Tried on server. Tried on local machine. Same results

Any ideas?Attachment 31948

You can try this. It's the Last Author that seems to take the long time

Code:

---

Option Explicit


Dim ws As Worksheet
Dim oApp As Application
Dim oFSO As Object


Sub test1()
    Dim folderPath As String
 
  ' Prompt user to select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1)
    End With
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")
   
    Set oApp = New Application
    oApp.Visible = False
    oApp.DisplayAlerts = False


    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("File Details").Delete
   
    Worksheets.Add.Name = "File Details"
    Set ws = Worksheets("File Details")
    ws.Range("A1:C1").Value = Array("Filename", "Date Modified", "Modified By")


    Call ListFilesRecursive(oFSO.GetFolder(folderPath))


    Application.ScreenUpdating = True
    Application.DisplayAlerts = False
    Application.StatusBar = False
   
    ws.Select
    ws.Rows(2).Select
    ActiveWindow.FreezePanes = True
    ws.Columns("A:C").EntireColumn.AutoFit
   
   
    MsgBox "Done"
   
End Sub




Sub ListFilesRecursive(Flder As Object)
    Dim oFile As Object, oSubfolder As Object
    Dim sExt As String
   
    For Each oFile In Flder.Files
        sExt = LCase(oFSO.GetExtensionname(oFile.Name))
        Select Case sExt
            Case "xlsx", "xlsm"
                Call AddData(oFile)
        End Select
    Next


    For Each oSubfolder In Flder.Subfolders
        DoEvents
        Call ListFilesRecursive(oSubfolder)
    Next


End Sub




Private Sub AddData(Fil As Object)
    Dim wb As Workbook
    Dim L As Long
   
    oApp.ScreenUpdating = False
    oApp.DisplayAlerts = False
    oApp.EnableEvents = False
    Set wb = oApp.Workbooks.Open(Fil, ReadOnly:=True)
   
    With ws
        L = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        .Cells(L, 1).Value = Fil.Path
        .Cells(L, 2).Value = Fil.DateLastModified
        .Cells(L, 3).Value = wb.BuiltinDocumentProperties("Last Author")
    End With
   
    wb.Close False
   
    Application.StatusBar = Fil.Path
   
End Sub

---

battle lines drawn in the sand....:devil2:

Code:

---

Sub GetWorkbookInfo()
    Dim newSheet As Worksheet
    Dim filePath As String
    Dim fso As Object
    ' FileSystemObject
    Dim file As Object
    ' File object
    ' Create a new sheet
    Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newSheet.Name = "Workbook Info"
    ' Set headers
    newSheet.Cells(1, 1).Value = "File Name"
    newSheet.Cells(1, 2).Value = "Last Modified Date"
    newSheet.Cells(1, 3).Value = "Last Modified By"
    ' Get the full path of the current workbook
    filePath = ThisWorkbook.FullName
    ' Create an instance of the FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Get the file object
    Set file = fso.GetFile(filePath)
    ' Write the information to the new sheet
    newSheet.Cells(2, 1).Value = file.Name
    newSheet.Cells(2, 2).Value = file.DateLastModified
    ' Attempt to get the last modified by
    On Error Resume Next
    newSheet.Cells(2, 3).Value = file.Properties("Last Modified By")
    On Error GoTo 0
    ' Autofit the columns
    newSheet.Columns("A:C").AutoFit
    MsgBox "Workbook information has been written to the '" & newSheet.Name & "' sheet.", vbInformation
    ' Clean up object variables
    Set file = Nothing
    Set fso = Nothing
    Set newSheet = Nothing
End Sub

---

And.... just in case you are looking for the same information but from multiple files in a folder

Code:

---

Sub GetFileInfo()
    Dim fso As Object
    ' FileSystemObject
    Dim folder As Object
    ' Folder object
    Dim file As Object
    ' File object
    Dim newSheet As Worksheet
    Dim lastRow As Long
    Dim filePath As String
    Dim i As Long
    ' Create a new sheet
    Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newSheet.Name = "File Information"
    ' Set headers
    newSheet.Cells(1, 1).Value = "File Name"
    newSheet.Cells(1, 2).Value = "Last Modified Date"
    newSheet.Cells(1, 3).Value = "Last Modified By"
    ' Note: This might not always be available
    ' Get the path of the current workbook
    filePath = ThisWorkbook.Path
    ' Create an instance of the FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Get the folder object
    Set folder = fso.GetFolder(filePath)
    i = 2
    ' Start writing data from the second row
    ' Loop through each file in the folder
    For Each file In folder.Files
        newSheet.Cells(i, 1).Value = file.Name
        newSheet.Cells(i, 2).Value = file.DateLastModified
        ' Attempt to get the last modified by - this might not always work
        On Error Resume Next
        newSheet.Cells(i, 3).Value = file.Properties("Last Modified By")
        On Error GoTo 0
        i = i + 1
    Next file
    ' Autofit the columns for better readability
    newSheet.Columns("A:C").AutoFit
    MsgBox "File information has been written to the '" & newSheet.Name & "' sheet.", vbInformation
    ' Clean up object variables
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
    Set newSheet = Nothing
End Sub

---

Vast improvement on generating the Last Author. Thanks so much for your time!

Not sure why the Last Author (on either script) is sluggish.

I actually put together a script (again through chatgpt because I haven't programmed in like 25 years) that will read the contents of given cells from xlsm/xlsx but it would require me to update about 33 spreadsheets right now plus the template that I copy and rename for each project (I'll admit that my project directory and copy/rename an xlxs is an old school batch file).

If you have a solution, would you kindly go to the thread tools dropdown and mark the thread as solved please?

Quote:

---

Originally Posted by TataDuende

Vast improvement on generating the Last Author. Thanks so much for your time!

Not sure why the Last Author (on either script) is sluggish.

---

Last Author is not exposed to FileSystemObject so each workbook must be opened. BuiltinDocumentProperties ("Last Author") read, and then the workbook closed

Lots of workbooks so it all adds up

There was a method I came accross that supposedly uses Explorer to get it but I couldn't get it to work

I'm going to give you the "win" Paul as I am unable to determine from the OP's response whether they found success from any of our proposed solutions or from their renewed chatgp enquiry.

AB - not a contest. Call it a draw or push

Don't know if the OP will come back, but I did find the sub I had for reading file propertiies directly via Explorer without the overhead of opening the workbook

Timing takes ~13 seconds to pull data from 220 files from recursive folders

So I'm punching everything into a workbook so that I can keep a record of workflow.

I've butchered the code to: hide column E (link), add in a sort by descending order (column A) plus a link to the spreadsheet based on column E (no longer need shortcuts stored).

This is all to keep track of the data sent in by surveyors and to maintain my own workflow.

Thanks again to everyone for their help and ideas.

Not seeing solved. Seeing unsolved. Help?

It's alread tagged as SOLVED

Attachment 31961

I took the liberty of marking the thread as Solved given the delay in the OP doing so.