Sluggish Script when accessing Last Author

[TataDuende]

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?31948

[Paul_Hossler]

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



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

[Aussiebear]

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



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.Coun t))
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

[Aussiebear]

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



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.Coun t))
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

[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.

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).

[Aussiebear]

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

[Paul_Hossler]

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

[Aussiebear]

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.

[Paul_Hossler]

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

[TataDuende]

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.

[TataDuende]

Not seeing solved. Seeing unsolved. Help?

[Paul_Hossler]

It's alread tagged as SOLVED

31961

[Aussiebear]

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