Macro to check if folder/subfolder exist for any user if not create them and save file

[1nk3d]

Hello all.

I am looking for a 3 in one here. I have a macro that will save a file automatically when ran. However, I am looking to use a new macro for a workbook.

I do not have any code right now, as everything I found has not worked.

What I want to do is check if a folder/subfolder exist on a users desktop, however everyone who will have access, has their own user.

Ideally it would be saved on the desktop under Reports/Feb (I can change the macro each Month as needed.

If that path does not exist, I want the macro to create it

The last part would be saving it as todays date & report.

 

[John_w]

See if this Test macro gets you started. It creates the Desktop subfolder "\Reports\Feb" if it doesn't exist and saves the workbook as "< today's date in the format yyyy-mm-dd ><today's date="" in="" the="" format="" yyyy-mm-dd=""> Report.xlsm" in the subfolder.

Public Sub Test()

    Dim desktopSubfolder As String
    
    desktopSubfolder = Create_Desktop_Subfolder("\Reports\Feb")
    ThisWorkbook.SaveCopyAs desktopSubfolder & "\" & Format(Date, "yyyy-mm-dd") & " Report" & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
    
End Sub


Private Function Create_Desktop_Subfolder(subfoldersPath As String) As String

    Dim desktopPath As String
    Dim folders As Variant
    Dim i As Long
    
    desktopPath = Get_SpecialFolderPath("Desktop")
    folders = Split(subfoldersPath, "\")
    For i = 0 To UBound(folders)
        If folders(i) <> "" Then
            desktopPath = desktopPath & "\" & folders(i)
            If Dir(desktopPath, vbDirectory) = vbNullString Then MkDir desktopPath
        End If
    Next

    Create_Desktop_Subfolder = desktopPath
    
End Function


Private Function Get_SpecialFolderPath(specialFolderPath As String) As String

    Dim WSshell As Object
     
    Set WSshell = CreateObject("WScript.Shell")
    Get_SpecialFolderPath = WSshell.SpecialFolders(specialFolderPath)
    Set WSshell = Nothing
    
End Function

</today's>

 

[1nk3d]

I am getting run time error 75, path/file access error

 

[John_w]

A silly Microsoft 'gotcha'. If the argument to SpecialFolders is the String variable "Desktop", it returns the Public Desktop folder, otherwise if it's a Variant, it returns the User's Desktop folder. Therefore change this line as shown:

    Get_SpecialFolderPath = WSshell.SpecialFolders(CVar(specialFolderPath))

 

[1nk3d]

Which line do I replace? I am getting a variety of errors and trying different lines...

A silly Microsoft 'gotcha'. If the argument to SpecialFolders is the String variable "Desktop", it returns the Public Desktop folder, otherwise if it's a Variant, it returns the User's Desktop folder. Therefore change this line as shown:

    Get_SpecialFolderPath = WSshell.SpecialFolders(CVar(specialFolderPath))

 

[1nk3d]

I think I figured it out, the third section correct?

 

[John_w]

Yep, the line which starts "Get_SpecialFolderPath = WSshell..."

 

[1nk3d]

Thank you so much! What if I want to add a message box to pop up indicating where the file was saved and the file name? Is that possible? Or just one that says report saved

 

[John_w]

Try this version of the Test macro:

Public Sub Test()

    Dim desktopSubfolder As String
    Dim fullFileName As String
    
    desktopSubfolder = Create_Desktop_Subfolder("\Reports\" & Format(Date, "Mmm"))
    fullFileName = desktopSubfolder & "\" & Format(Date, "yyyy-mm-dd") & " Report" & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
    ThisWorkbook.SaveCopyAs fullFileName
    MsgBox "Saved " & fullFileName
    
End Sub

Another change is that the macro now saves the file in the subfolder for the current month, so there is no need to edit the code from month to month.

 

[1nk3d]

Works like a dream! Thank you very much!