I have this code:
Sub PrintPDF()
Dim wsReport As Worksheet
Dim confirm As Long
Dim filename, reportsPath As String
Dim printArea As Range
Set wsReport = ThisWorkbook.Worksheets("Test Status")
Set printArea = wsReport.Range("A1:AG80")
'Generate Reports folder path
'reportsPath = ThisWorkbook.Path & "\Reports\"
reportsPath = "C:\"
'Generate filename to be printed
Dim LValue As String
LValue = Format(Date, "yyyymmdd")
fp = reportsPath & Range("Project!clientName").Value & "_TestReport_" & LValue & ".pdf"
'Confirm or Cancel the action
confirm = MsgBox("the Test execution report (" & fp & ") will be printed as PDF in the folder " & reportsPath & " .", vbOKCancel + vbQuestion, "Printing Test report")
If confirm = vbCancel Then
Exit Sub
End If
'Set page orientation to landscape
wsReport.PageSetup.Orientation = xlLandscape
'wsReport.PageSetup.Orientation = xlPortrait
Application.ScreenUpdating = False
With ActiveSheet.PageSetup
.printArea = Worksheets("Test Status").UsedRange
'.printArea = wsReport.UsedRange
'.printArea = Worksheets("Test Status").UsedRange
.Orientation = xlLandscape
.FitToPagesWide = 1
.Zoom = False 'I have added this line
End With
printArea.ExportAsFixedFormat Type:=xlTypePDF, filename:=fp, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
This code is activated when the button on the sheet is pressed.
Once I press the button, I got the message box with the filename and path where the file will be stored.
once pressed on "OK" button I got this error:
Run-Time Error '1004' Document not saved. The document may be open or
an error may have been encountered
I'm using Office 365
fixed,
seems that the issue was caused by directory grant.
Btw, I changed the reportsPath
reportsPath = ThisWorkbook.Path & "\Reports\"
And I've added the check to create the directory in case it doesn't exist.
reportsPath = ThisWorkbook.Path & "\Reports\"
If Dir(reportsPath, vbDirectory) = "" Then
create = MsgBox("The Directory " & reportsPath & " doesn't exist. ", vbOKCancel + vbQuestion, "Do you want to create it?")
If create = vbCancel Then
Exit Sub
End If
MkDir reportsPath
Stop
End If
Now it works, no runtime error anymore.
Related
I have code that run when file Opens that renames file data in Inputbox using ActiveWorkbook.SaveAs. It works fine under following conditions.
Spreadsheet opened in "File Explorer"
Spreadsheet opened in Excel Browser screen.
When spreadsheet is opened thru Excel Open/Menu, Sub will not save new file at initial Open, but if I run sub after, no issues.
Private Sub Workbook_Open()
'Checks Status of Workbook upon Openning
Dim PON, INP As String
Dim strPath, JC As String
Dim strNewName, NewName As String
INP = Worksheets("CHK").Range("J1").Value
Worksheets("CHK").Range("Q1").Value = "Good"
Worksheets("Form").Select
Worksheets("Form").Range("C4").Select
Call Protect_All_Sheets_Pswrd
If INP = "New" Then
Call Save_PO_File
Else
If INP = "Done" Then
MsgBox "This Check List is COMPLETE!!!!!"
Call Save_PO_File
Else
Call PGUP_PGDN
UserForm2.Show
End If
End If
End Sub
Sub Save_PO_File()
Dim strPath As String
Dim strNewName, NewName As String
1000 On Error GoTo ErrorHandler
Answer = MsgBox("Do You want to start NEW Rental Checklist?", vbQuestion + vbYesNo + vbDefaultButton2)
If Answer = vbYes Then
Worksheets("CHK").Range("S6").Value = 0
PON = InputBox("Please enter PO Number to Start Checklist:", Xpos:=2880, Ypos:=1440)
If Len(PON) > 7 Then
MsgBox "PO number can only be a Maximum of 7 digits"
GoTo 1000
End If
If PON = "" Then
MsgBox "MUST ENTER PO#"
GoTo 1000
End If
strNewName = "Rental Checklist PO " + PON & ".xlsm"
strPath = ActiveWorkbook.Path
NewName = strPath & "\" & strNewName
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=NewName
Application.DisplayAlerts = True
If ActiveWorkbook.Name <> strNewName Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
End If
MsgBox strPath & "/" & vbNewLine & vbNewLine & strNewName, , "NEW Workbook Saved As"
Call Clean_Form 'Clear Form
Worksheets("Form").Range("C9").Value = PON 'Input PO #
Worksheets("Form").Range("C4").Select
Call PGUP_PGDN
Else
Call Confirm_ADMIN
End If
Exit Sub
ErrorHandler:
MsgBox "Had Error... Check File Name"
Exit Sub
End Sub
Tried different folders, adding error checking...etc
I have written the following code tied to a command button to prompt the user to define a save path, export the active sheet to PDF and open it, then delete the sheet after it's been exported and activate a different sheet. The code works to completion but right at the end, I get a the following error:
Run-time error '-2147221080 (800401a8)':
Automation error
Below is my code. Any help would be immensely appreciated.
Private Sub ExceptionPrint_Click()
Sheet_Name = ActiveSheet.Name
PDF_Name = "Exception - " & ActiveSheet.Name & ".pdf"
Set File_Dialog = Application.FileDialog(msoFileDialogFolderPicker)
File_Dialog.AllowMultiSelect = False
File_Dialog.Title = "Select the Desired Location"
If File_Dialog.Show <> -1 Then
Exit Sub
End If
PDF_Name = File_Dialog.SelectedItems(1) & "\" & PDF_Name
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=PDF_Name, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
If Sheets("Data").Range("H12").Value = "W1" Then
Sheets("Week 1").Activate
Sheets("Data").Range("H12").Value = ""
Else
Sheets("Week 1").Activate
Sheets("Data").Range("H12").Value = ""
End If
Application.DisplayAlerts = False
Sheets(Sheet_Name).Delete
Application.DisplayAlerts = True
End Sub
I've tried everything I could think of, but I'm not that great with VBA to begin with.
Assign the active sheet to a reference at the start and use that reference throughout the program. Also try to catch early any errors that the user might make.
Option Explicit
Private Sub ExceptionPrint_Click()
Dim wb As Workbook, wsPDF As Worksheet, PDF_Name As String
' validation
Set wb = ThisWorkbook
Set wsPDF = wb.ActiveSheet
With wsPDF
If .Name = "Week 1" Or .Name = "Data" Then
MsgBox "Sheet " & wsPDF.Name & " must not be selected", vbCritical
Exit Sub
ElseIf WorksheetFunction.CountA(.UsedRange) = 0 Then
MsgBox .Name & " is blank", vbCritical
Exit Sub
End If
End With
' select folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select the Desired Location"
If .Show <> -1 Then Exit Sub
PDF_Name = .SelectedItems(1) & "\Exception - " & wsPDF.Name & ".pdf"
End With
' print and delete
wsPDF.ExportAsFixedFormat Filename:=PDF_Name, Type:=xlTypePDF, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
wsPDF.Delete
Application.DisplayAlerts = True
' finish
With wb
.Sheets("Week 1").Activate
.Sheets("Data").Range("H12").Value = ""
End With
End Sub
I ended up just leaving a "Delete Sheet" button on the sheet in question rather than having it automatically delete. Thank you everyone.
I'm using the following code to save an updated workbook.
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
gwbTarget.Activate <<<<<<<<<<<<<<<<<<<<<<<
Application.DisplayAlerts = False
gwbTarget.SaveAs txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = False
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Exit Sub
Err_cmdSaveUpdatedWB_Click:
MsgBox "The following error occurred inthe [cmdSaveUpdateWB_Click] event handler." & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & "Error descriptioin: " & Err.Description
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
As noted in the title, the SaveAs operation fails. I've determined that the failure is a result of having the workbook to be saved losing the focus. I can step through the code and get the error. Once the error is generated, selecting Debug in the error message box and then pressing F5 to run the code will result in the workbook saving correctly. Placing Debug.Print statements before and after the Activate method of the worbook to be saved indicates that the active wokbook is the workbook containing the code and the form used to update the workbook. Placing a print statement in the Immediate wondow that prints the ActiveWorkbook.Name will result in printing the name of the workbook to be saved - gwbTarget.Name. Pressing F5 then runs the code correctly.
I have been unable to figure out why the workbook to be saved loses the focus. I placed delays, multiple activation statements, local variables to use for the workbookto be saved, and for the name of the workbook to be saved. Any help or ideas as to why this is happening and how to fix it will be greatly appreciated.
I did make some changes. The code is listed below...
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
Dim wbSave As Workbook
Set wbSave = gwbTarget
gwbTarget.Activate
Application.DisplayAlerts = False
''''''' gwbTarget.SaveAs txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wbSave.SaveAs fileName:=txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = False
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Set wbSave = Nothing
Exit Sub
Err_cmdSaveUpdatedWB_Click:
MsgBox "The following error occurred inthe [cmdSaveUpdateWB_Click] event handler." & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & "Error descriptioin: " & Err.Description
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
I've changed the code to more closely resemble the suggestion below. The listing is below, along with the variable definitions as they were upon entry into the program. The Excel code is running in a Citrix environment which may effect timing but shouldn't have any other effect on code execution.
I deleted the other code versions for brevity. The following code is what has worked. The key issue is that the workbook to be saved must be the active workbook when the SaveAs method is invoked.
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
Dim wbSave As Workbook
Dim wsActive As Worksheet
Dim sNWBName As String
Application.DisplayAlerts = False
sNWBName = txtUpdWorkbookName.Value
Set wbSave = gwbTarget
wbSave.Activate
Set wsActive = wbSave.ActiveSheet
wbSave.SaveAs fileName:=sNWBName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Set wbSave = Nothing
Exit Sub
Err_cmdSaveUpdatedWB_Click:
Dim strErrMsg As String
strErrMsg = "Error Number: " & Err.Number & " Desc: " & Err.Description & vbCrLf & _
"Source:" & Err.Source & vbCrLf & _
"Updating Workbook: " & vbCrLf & " " & gwbTarget.Name & vbCrLf & _
"Selected Worksheet: " & gwsTrgSheet.Name & vbCrLf & _
"Active Workbook: " & vbCrLf & " " & ActiveWorkbook.Name & vbCrLf & _
"Worksheet: " & ActiveSheet.Name & vbCrLf & _
"Code Segment: cmdSaveUpdatedWB_Click event handler"
RecordErrorInfo strErrMsg
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
Why don't you start with something like this
Private Sub cmdSaveUpdatedWB_Click()
Dim gwbTarget As Workbook
Set gwbTarget = Workbooks("workbook_name.xlsm") 'correct extension needed, workbook must be open
wb.SaveAs Filename:=gwbTarget.Path, FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "Last saved: " & gwbTarget.BuiltinDocumentProperties("Last Save Time")
End Sub
Change one thing at a time to make it more like yours and hopefully it'll all work fine!
Update
As per the comments. If you are trying to open, update and close hundreds of workbooks. You can use this as a guide:
Sub ChangeWorkbooks()
Application.ScreenUpdating = False
Dim wbPaths As Range, wbSaveFilenames As Range
With Sheet1 'you will need to update this and the ranges below
Set wbPaths = .Range("A1:A650") 'including file extensions
Set wbSaveFilenames = .Range("B1:B650") 'including file extensions
End With
Dim i As Integer, totalBooks As Integer
Dim wbTemp As Workbook
totalBooks = wbPaths.Rows.Count
For i = 1 To totalBooks
Application.StatusBar = "Updating workbook " & i & " of " & totalBooks 'display statusbar message to user
Set wbTemp = Workbooks.Open(wbPaths.Cells(i, 1), False)
'make changes to wbTemp here
wbTemp.SaveAs wbSaveFilenames.Cells(i, 1)
wbTemp.Close
Next i
Set wbTemp = Nothing
Application.ScreenUpdating = True
Applicaton.StatusBar = False
End Sub
Being an absolute VBA novice, I've pieced together some code that will run through an Excel sheet, checking everything's there, and then saving the sheet as a PDF file. I am, however, having some trouble with the saving part of the code. I keep getting the error "Compile error: Expected:=" to this line:
`Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,Quality:=xlQualityStandard,IncludeDocProperties:=True,IgnorePrintAreas:=False, OpenAfterPublish:=False)ยด
Am I just being a complete n00b here?
The whole thing looks like this:
Sub mcrSave()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
'Check for mandatory fields
If Range("B3").Value = "" Then MsgBox ("Please fill in applicant")
Exit Sub
If Range("C1").Value = "" Then MsgBox ("Please fill in project title")
Exit Sub
If Range("H3").Value = "" Then MsgBox ("Please fill in date of application")
Exit Sub
If Range("C5").Value = "" Then MsgBox ("Please fill in expected cost")
Exit Sub
If Range("C7").Value = "" Then MsgBox ("Please fill in time schedule")
Exit Sub
If Range("B10").Value = "" Then MsgBox ("Please fill in project description")
Exit Sub
If Range("B18").Value = "" Then MsgBox ("Please fill in potential benefits")
Exit Sub
If Range("B26").Value = "" Then MsgBox ("Please fill in potential drawbacks")
Exit Sub
If Range("B34").Value = "" Then MsgBox ("Please fill in internal/external ressources")
Exit Sub
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename(InitialFileName:=strPathFile, FileFilter:="PDF Files (*.pdf), *.pdf", Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,Quality:=xlQualityStandard,IncludeDocProperties:=True,IgnorePrintAreas:=False, OpenAfterPublish:=False)
'confirmation message with file info
MsgBox "PDF file has been created: " & vbCrLf & myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Syntax error. The correct syntax is either
call Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,...)
or
Wsa.ExportAsFixedFormat Type:=xlTypePDF,Filename:=myFile,...
Change your Export command to the following:
Wsa.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Also, you need to change your Mandatory field checks so each looks like:
If Range("B3").Value = "" Then
MsgBox ("Please fill in applicant")
Exit Sub
End If
I have written a sub that should save worksheet 2 as a csv file with a time stamp in it. I let the user choose the file path with the get path sub, then when the user clicks 'okay' the program fails and says
run time error 9, subscript out of range.
Can you please help me figure out where/why my program is diong this?
Public Sub save()
Dim x As Integer
Dim FName As String
x = MsgBox("Are you sure?!?", vbYesNo, "Send File")
If x <> vbYes Then
GoTo Send_file_end:
End If
FName = get_path & "cambs_uplaoded_trades" & Format(Time, "hh mm ss") & ".csv"
ActiveWorkbook.Worksheets("sheet2").SaveAs Filename:=FName, FileFormat:=xlCSV
MsgBox "saved "
Send_file_end:
End Sub
here is my get path function
Function get_path() As String
Dim dlg As Variant
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
dlg.AllowMultiSelect = False
If dlg.Show <> -1 Then
get_path = ""
Else
get_path = dlg.SelectedItems(1) & "\"
End If
End Function
So i'll show you my solution just in case your interested:
Sheets("Sheet2").Activate
FName = get_path & "cambs_uplaoded_trades" & Format(Time, "hh mm ss") & ".csv"
ActiveWorkbook.Worksheets("Sheet2").SaveAs Filename:=FName, FileFormat:=xlCSV
MsgBox "saved "
ActiveSheet.Name = "Sheet2"
Sheets("Sheet1").Activate
So i activated sheet two before the name was changed, then saved it, then i changed the name of the active workshet back to sheet2.
thanks for you input!