Simple macro to SaveAs a basic excel file to SharePoint and then do a bunch of other stuff. The macro works perfectly when the user has an access to the specified folder FLUX PL.
ActiveWorkbook.SaveAs Filename:="https://xxxxcorp.sharepoint.com/sites/CEEControlling/Shared%20Documents/Reporting/FLUX%20Analysis/FLUX%20PL/FLUX%20analysis%20PL%20" & Date & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If the user doesn't have access (so he does not see the file), it half-saves in place of the original file so it is broken and I have to go to the previous version.
I tried include code to check if I have access/the folder exists in SharePoint, but it gives me
Run-time error '52': Bad file name or number.
mypath = "https://xxxxcorp.sharepoint.com/sites/CEEControlling/Shared%20Documents/Reporting/FLUX%20Analysis/FLUX%20PL"
mypath = Replace(Replace(mypath, "https:", ""), "/", "\")
mypath = Replace(mypath, Split(mypath, "\")(2), Split(mypath, "\")(2) & "#SSL")
If Dir(mypath, vbDirectory) = "" Then
MsgBox ("Doesnt exist!")
Else:
MsgBox ("Exists!")
End If
I also thought about On Error Goto [label] but by the time it gives me error the file is already renamed (and the original one broken).
I would be grateful for any help.
If anyone would need it in the future, I got it working. I try to save it and if it gives me error I use On Error GoTo and open SaveAs Dialog.
On Error GoTo savior
ActiveWorkbook.SaveAs Filename:= "https://xxxxcorp.sharepoint.com/sites/CEEControlling/Shared%20Documents/Reporting/FLUX%20Analysis/FLUX%20" & Range("H2").Value & "/FLUX%20analysis%20" & Range("H2").Value & "%20" & Date & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = False
On Error Goto 0
GoTo rest
savior:
MsgBox ("You do NOT have access to the default folder on Teams:" & vbNewLine & "Controlling CEE >> Reporting >> Files >> FLUX Analysis >> FLUX " & Range("H2").Value & vbNewLine & vbNewLine & "Select different location for the new trimmed file!")
Filename = "FLUX analysis " & Range("H2") & " " & Date
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Excel Files (*.xlsx), *.xlsx", Title:="Select File Location", _
InitialFileName:=Filename)
If varResult <> False Then
ActiveWorkbook.SaveAs Filename:=varResult, _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = False
End If
On Error Goto 0
GoTo rest
rest:
Related
This code creates a folder, but it does not save the file in it.
It shows an alert message
file name or path doesn't exist
startPath = "C:\Users\OsmonBek\Documents\macros"
myName1 = ActiveSheet.Range("A1").Text
Dim folderPathWithName As String
folderPathWithName = startPath & "\" & myName1
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
End If
' Save File
ActiveWorkbook.SaveAs Filename:= _
"folderPathWithName & \legend F22 A&P report " & Format(Now(), "DD-MMM-YYYY") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
You have your quote characters wrong. Probably you mean folderPathWithName & "\legend F22 A&P report " so you get the content of the path variable into the filename.
Write the filename into an intermediate variable, that helps finding such errors:
' Save File
Dim newFileName As String
newFileName = folderPathWithName & "\legend F22 A&P report " & Format(Now(), "DD-MMM-YYYY") & ".xlsx"
ActiveWorkbook.SaveAs Filename:= newFileName _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
My code runs perfectly when I save to my local drive, but when I save to the shared drive I get Runtime Error 5? How is this occurring?
I have unmerged cells and put it as center across selection
Ensured that the whole document is within the print margins
Edit: I have tried saving into the folder directory above where I was saving and it works. I understand that there is a character limit (pathname and title), which might be the problem? Is there a way to solve this?
The error is in the following area:
'Creating Only the PDF based on Company Network - there is an existing folder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
This is the whole code:
Option Explicit
Private Function selectfolder()
'Defining the Variables
Dim user_name As String
user_name = Environ("username") 'to pick up the username from work environment
'Prompt for folder creation
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder to save"
.InitialFileName = "C:\Users\" & user_name & "\Department\"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function 'if user does not press OK, end the function'
selectfolder = .SelectedItems(1)
End With
End Function
Sub SaveActiveSheetAsPDF()
'Create a message box to ask user before proceeding
If MsgBox("This will print to PDFs. Continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Printing to PDFs") = vbNo Then Exit Sub
'Defining the Type of Variables
Dim inputrange As Range 'Range represents a cell or multiple cells in Excel
Dim cell As Range
Dim network, Address, Fldr, Title As String
'If user does not choose a folder
Address = selectfolder
If Address = "" Then
Exit Sub
End If
'Determine (set) where validation comes from - create a reference point
Set inputrange = Evaluate(Range("G2").Validation.Formula1)
For Each cell In inputrange
Range("G2").Value = cell.Value
'Defining the Company Network Folder variables
network = Range("C6").Value
Fldr = Address & "\" & network
Title = "MonthlyReport (" & Format(Range("C8"), "mmmm") & ") - " & ActiveSheet.Range("B2").Value & " (" & ActiveSheet.Range("G2").Value & ")"
'Creating the folder based on Company Network - No existing folder
If Dir(Fldr, vbDirectory) = "" Then
'Create a folder
MkDir Fldr
'Save Active Sheet as PDF and to Company Network file
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
'Creating Only the PDF based on Company Network - there is an existing folder
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
End If
Next cell
'Create a message box at end of task to inform user it is complete
MsgBox "Generation of PDF Reports and Folders Completed", vbInformation, "Complete"
End Sub
It is difficult to diagnose problems with network drive without more information, but I could suggest a workaround instead.
You could save the file on your local drive and then move it using the File System Object in VBA. Here's how it would look like:
'Save Active Sheet as PDF in temporary folder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Environ("TEMP") & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
'Move PDF to Company network drive
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.MoveFile Environ("TEMP") & "\" & Title & ".pdf", Fldr & "\" & Title & ".pdf"
Note that for this code to work, you need a reference to the Microsoft Scripting Runtime Library.
I'm trying to save a file to an Onedrive folder that syncs within file explorer. Do I need a network path for this to work properly? This is what I have so far:
Sub Macro4()
Dim myDir, strFilename, strPathname, strDateTime As String
strDateTime = " (" & Format(Now, "hhmm AM/PM") & ")"
myDir = Environ("USERPROFILE") & "\Folder 1\Folder2\Folder3\" & Worksheets("Private").Range("L5").Value
strFilename = Worksheets("HWR DATA - Craft").Range("C1").Value
strPathname = myDir & "\" & strFilename
MyMkDir myDir & "\"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strPathname & strDateTime & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
L5 refers to a cell that contains the following data:
Folder A\Folder B\Folder C
I found the issue. The problem was with my code running into a problem with Microsoft's max length for the path to my folder. (256-character limit for creating links to other files).
I have an Excel spreadsheet that should be saved on the desktop when the User presses a button. For this I use the following VBA to check if the file already exists on the Desktop:
Sub SaveFileOnDesktop()
Do
New_Filename = Application.InputBox("Please type in name for new file?")
If New_Filename = False Then Exit Sub
If Len(Dir("C:\Users\" & Environ("Username") & "\Desktop\" & New_Filename & ".xlsm")) = 1 _
Then MsgBox ("File alreday exists. Please change file name.")
Loop Until Len(Dir("C:\Users\" & Environ("Username") & "\Desktop\" & New_Filename & ".xlsm")) = 0 Or New_Filename = False
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\" & New_Filename & ".xlsm"
MsgBox ("File saved successfully on desktop.")
End Sub
Now when the User enters a file name that already exists on the desktop the loop continues. Once the user enters another name the loop does stop. This functionality works fine so far.
The only issue I have is that the MsgBox ("File alreday exists. Please change file name.") does not appear if the user enters an exisitng name into it.
What do I have to change in my code so the message box appears?
This cannot be True, thus the MsgBox does not appear:
If Len(Dir("C:\Users\" & Environ("Username") & "\Desktop\" & New_Filename & ".xlsm")) = 1
The length would be at least 10+, if the file is present or 0 if it is not present. 1 cannot be achieved.
To make it appear, write:
If Len(Dir("C:\Users\" & Environ("Username") & "\Desktop\" & New_Filename & ".xlsm")) > 1
or even:
If Len(Dir("C:\Users\" & Environ("Username") & "\Desktop\" & New_Filename & ".xlsm"))
I am getting a Runtime error 1004 document not saved using vba when I want to save an Excel workbook in my folder on desktop. Here are the details of my code:
Private Sub Save_Click()
'Popup the Window "Save As"
Application.DisplayAlerts = False
MsgBox "Do not change the default file name proposed on the next step please !"
Dim fName As Variant
Dim DName As String ' Variable storing name of excel workbook which has to be saved
DName = UserForm.CustomerApplication.Value & " - " & UserForm.L2GType.Value
& " - " & UserForm.Title.Value & " - " & UserForm.Country.Value & "(" &
Year(Date) & ")"
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName = False Then
Exit Sub
ActiveWorkbook.SaveAs filename:=fName, FileFormat:=51
ActiveWorkbook.Close
End Sub
I think you are missing an 'End If' at the bottom of your code. The 'If fName = False Then...' part. Try the following
Private Sub Save_Click()
'Popup the Window "Save As"
Application.DisplayAlerts = False
MsgBox "Do not change the default file name proposed on the next step please !"
Dim fName As Variant
Dim DName As String ' Variable storing name of excel workbook which has to be saved
DName = UserForm.CustomerApplication.Value & " - " & UserForm.L2GType.Value
& " - " & UserForm.Title.Value & " - " & UserForm.Country.Value & "(" &
Year(Date) & ")"
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName = False Then
Exit Sub
End If
ActiveWorkbook.SaveAs filename:=fName, FileFormat:=51
ActiveWorkbook.Close
End Sub
fName is a String, therefore you can't compare it with False, but with "False".
Try replacing the last section of your code with the lines below:
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
fileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName <> "False" Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=51
Else
MsgBox "No File was selected !"
Exit Sub
End If
Application.DisplayAlerts = True
Note: using FileFormat:=51, means xlOpenXMLWorkbook, an .xlsx format (without MACROs).
However since you want to use the SaveAs command with ThisWorkbook, which contains this code, you will get a prompt screen that asks if you want to save it as .xslx , which means all your code will be lost.
You can select FileFormat:=52, means xlOpenXMLWorkbookMacroEnabled, an .xlsm format (with MACROs).