Macro to Save a copy of the Workbook to a specified location on OneDrive for multiple users.

[tsampson11]

Our company uses Onedrive for our team file distribution. All work is done locally and then files are synced up when wifi is available.
I have a few macros built in to our files to ready them for client distribution. The problem is sometimes the files get overwritten after the macros run and we lose some important background information in the process.

I would like to create a macro that saves a copy of the file before we run our macros, or be added to the start of each one. I would like the copied backup files from any user to save to a specific folder on OneDrive with the date and time attached to the end of the filename.
Finally, if possible, I would like the active file, to remain active. Meaning a copy of the file would be saved in the specified folder, and the active file would continue to run the rest of the macro.


I have tried a bunch of versions of the code, with the closest being this one:

Sub Saveasdesktop()

FileName = ActiveWorkbook.Name
user = Environ("Username")
desktop = "C:\Users\" & user & "\Desktop\Excel Backups\"
today = Format(Now(), "DD-Mmm-YYYY-hh-mm")
newFileName = Left(FileName, InStr(FileName, ".") - 1)

ThisWorkbook.SaveAs FileName:=desktop & newFileName & " " & today

End Sub


When I try to change the path to a OneDrive destination, I can't get it to work. This one also changes the active file to the copied version, which is not ideal.


Thanks for your help!

 

[tsampson11]

Playing with it a bit more, this seems to work well for me.
The only problem on some machines the file path tries to use a Sharepoint address and it doesn't work right. Not sure how to go about fixing that part, but the code works fine.

Sub SaveCopyToOneDrive()
Dim originalPath As String
Dim originalName As String
Dim newFileName As String
Dim newFilePath As String
Dim OneDriveFolderPath As String


OneDriveFolderPath = "C:\Users\YourUsername\OneDrive\BackupFolder\" ' Replace with the actual folder path

originalPath = ThisWorkbook.Path & Application.PathSeparator
originalName = ThisWorkbook.Name

newFileName = Left(originalName, Len(originalName) - Len(WorksheetFunction.Substitute(originalName, ".", ""))) & "_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"

newFilePath = OneDriveFolderPath & newFileName

ThisWorkbook.SaveCopyAs newFilePath

End Sub