VBA SaveAsPDF into current year/month shared OneDrive folder

[drefiek2]

Hi,
I have the following code which saves a sheet as a PDF into a shared OneDrive folder. It saves the PDF currently into a folder called "Unfiled", which then has to be manually filed away into the current year and month. 5-6 people have access to this spreadsheet and its shared folder home on SharePoint/OneDrive.

Sub SaveAsPDF()
'
' SaveAsPDF Macro
'
' Keyboard Shortcut: Ctrl+Shift+S
'
    Dim SharePointPath As String
    Dim PdfFileName As String
    Dim msg As String

    On Error GoTo SaveError

    SharePointPath = Environ("USERPROFILE") & "\OneDrive - COMPANY\Shift Handover\Archive\Unfiled\"

    PdfFileName = Replace(Range("D6").Value, "/", "") & ActiveSheet.Range("J6").Value

    If Dir(SharePointPath & PdfFileName & ".pdf") <> "" Then
    If MsgBox("Handover for this date and shift already exists. Overwrite?", vbExclamation + vbYesNo) = vbNo Then
      Exit Sub
    End If
    End If

    If Worksheets("Mechanics").Range("B15").Value = True Then
    Call DarkMode
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SharePointPath & PdfFileName, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Call DarkMode
    Else
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SharePointPath & PdfFileName, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End If

    msg = "Handover successfully uploaded to SharePoint!"
    MsgBox msg, vbInformation, "Upload Successful"
    Exit Sub

SaveError:
    msg = "Handover not uploaded to SharePoint. Please contact NAME on e-mail and use the backup document for your handover." & vbCr & vbCr & Err.Number & " - " & Err.Description
    MsgBox msg, vbCritical, "Upload Failure"
End Sub

Note the PDF file name is today's current date in DD/MM/YYYY format (/'s removed as these are illegal characters in save name) followed by either "Day" or "Night" (cell J6)
E.g. 04082023Day

What I would like, if at all possible, is for the PDF to save into the current year and month folder, instead of having to manually move it at a later date. I'm not sure if this is beyond Excel's capabilities but please let me know either way! Each year has a folder and each year folder has 12 month folders inside it.

 

[John_w]

Try adding this after the SharePointPath = line:

SharePointPath = SharePointPath & Format(Date,"yyyy") & "\"
If Dir(SharePointPath, vbDirectory) = vbNullString Then MkDir SharePointPath

SharePointPath = SharePointPath & Format(Date,"mm") & "\"
If Dir(SharePointPath, vbDirectory) = vbNullString Then MkDir SharePointPath

Run this month, the code would assign the string "...\Unfiled\2023\08" to SharePointPath, creating the subfolders if they don't exist.

 

[drefiek2]

Try adding this after the SharePointPath = line:

SharePointPath = SharePointPath & Format(Date,"yyyy") & "\"
If Dir(SharePointPath, vbDirectory) = vbNullString Then MkDir SharePointPath

SharePointPath = SharePointPath & Format(Date,"mm") & "\"
If Dir(SharePointPath, vbDirectory) = vbNullString Then MkDir SharePointPath

Run this month, the code would assign the string "...\Unfiled\2023\08" to SharePointPath, creating the subfolders if they don't exist.

Fantastic, it works, thank you very much