Try to Display Active Workbook Creation Date in the last Column

[epoiezam]

Hi Guys,

Below is the whole code. Trying to get VBA to display Active Workbook - Creation Date in Cells(lRow, 73)/ Column "BU".
Multiple workbooks place in same folder.

In summary - Multiple workbooks are placed in a folder. VBA will go through them one by one for the search criteria. Once met, it will copy the whole row to the master file.
The prob is - unable to also copy workbook "Creation Date" at the end of the row. (Column "BU")

Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
Dim cdt
cdt = Format(ActiveWorkbook.BuiltinDocumentProperties.Item("Creation date"), "short date")

On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.Visible = False

strPath = UserForm1.Label44.Caption
strSearch = UserForm1.TextBox1.Value

lRow = 3

With Sheet2

Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)

strFile = Dir(strPath & "\*.csv")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(Filename:=strPath & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)

Application.Visible = False

For Each wks In wbk.Worksheets
Set rFound = ActiveSheet.Range("K:K").Find(what:=strSearch, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)

If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Cells(lRow, 1).EntireRow.Value = rFound.EntireRow.Value
.Cells(lRow, 70) = wbk.Name
.Cells(lRow, 71) = wks.Name
.Cells(lRow, 72) = rFound.Address

.Cells(lRow, 73) = ???? ----------------------------------------------------------------- HERE -----------------------------------------------------------------------------------


End If
Set rFound = wks.Range("K:K").FindNext(After:=rFound) ' column = Range("K:K"), all = Cells
Loop While strFirstAddress <> rFound.Address
Next

wbk.Close (True)
strFile = Dir

Loop
Application.Visible = False
.Columns("A:D").EntireColumn.AutoFit
End With


ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler


End Sub

 

[alansidman]

Adapt this to your needs.

Option Explicit

Sub GetDateCreated()

    Dim oFS As Object
    Dim strFilename As String

    'Put your filename here and amend this one to yours
    strFilename = "C:\Users\Alan\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB"


    'This creates an instance of the MS Scripting Runtime FileSystemObject class
    Set oFS = CreateObject("Scripting.FileSystemObject")

    MsgBox strFilename & " was created on " & oFS.GetFile(strFilename).DateCreated



    Set oFS = Nothing

End Sub

 

[epoiezam]

Adapt this to your needs.

Option Explicit

Sub GetDateCreated()

    Dim oFS As Object
    Dim strFilename As String

    'Put your filename here and amend this one to yours
    strFilename = "C:\Users\Alan\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB"


    'This creates an instance of the MS Scripting Runtime FileSystemObject class
    Set oFS = CreateObject("Scripting.FileSystemObject")

    MsgBox strFilename & " was created on " & oFS.GetFile(strFilename).DateCreated



    Set oFS = Nothing

End Sub

Hi Mr Alan.

Thank you so much for sharing. I truly appreciate it. It did gave me some ideas.
After a few tries, I managed to add the solution and the result is just beautiful.

.Cells(lRow, 1).EntireRow.Value = rFound.EntireRow.Value
.Cells(lRow, 70) = wbk.Name
.Cells(lRow, 71) = wks.Name
.Cells(lRow, 72) = rFound.Address
.Cells(lRow, 73) = fso.GetFile(strPath & "\" & strFile).DateCreated ------------ New added line -------