add cellvalue & system date time when saving excel in specific folder

[akika]

hi,


How can i add a specific cell value with system dateTime when saving an excel workbook?
and if the folder doesnot exist it should create it?


e.g <FileName>_<UserName>_<SystemDateTime>.xls
Code is to be triggered when the workbook is closed?

Sub filename_cellvalue()
   Dim Path As String
   Dim filename As String
   Dim strDir As String
   strDir = "D:\AB\TestDir"


    If Dir(strDir, vbDirectory) = "" Then
        MkDir strDir
    Else
        MsgBox "Directory exists."
    End If
   filename = Range("A1")
   ActiveWorkbook.SaveAs filename:=Path & filename & ".xls", FileFormat:=xlNormal
End Sub

[Kenneth Hobson]

 ActiveWorkbook.SaveAs filename:=strDir & filename & "_" & Environ("username") & "_" & Format(date, "d-m-yy") & ".xls", FileFormat:=56

Call the routine in ThisWorkbook object's BeforeClose event or add all of the routine in it. With the change above, in ThisWorbook object:

Private Sub Workbook_BeforeClose(Cancel As Boolean)  filename_cellvalue
End Sub

You may or may not want to force a save before the call.

[akika]

how can i include Time also to the format when saving it?

[Kenneth Hobson]

Use Now rather than Date and add the timestring format string. I also added a method to create all folders, not just one, if needed.

I like to build a string and use Debug.Print to view a run result before using it fully. Remove comments and after a run View the Immediate window to see the string.

Sub filename_cellvalue()
    Dim Path As String, filename As String
    Dim fn As String, strDir As String
    
    strDir = "D:\AB\TestDir\"
    filename = Range("A1")
    
    If Dir(strDir, vbDirectory) = "" Then
        'MkDir strDir
        Shell "cmd /c md " & """" & strDir & """", vbHide    'Drive must exist.
        Else
        MsgBox "Directory exists."
    End If
    
    fn = strDir & filename & "_" & Environ("username") & "_" & Format(Now, "d-m-yy hh:mm:ss") & ".xls"
    'Debug.Print fn
    'Exit Sub
    ActiveWorkbook.SaveAs fn, 56
End Sub