i want save chart to png format, (inputbox my png name)
my code is
Sub savechartaspng()
Dim fname As String
ActiveSheet.ChartObjects("Chart 1").Activate
If ActiveChart Is Nothing Then Exit Sub
fname = ThisWorkbook.Path & "\" & InputBox("filename") & ".png"
ActiveChart.Export FileName:=fname, filtername:="png"
MsgBox "saved"
End Sub
how inputbox = cancel or closed to exit sub and Do not save ?
tnx
Get the input from the InputBox first, check check to see if it's blank or not, and only continue if it's not blank.
Sub savechartaspng()
Dim fname As String
ActiveSheet.ChartObjects("Chart 1").Activate
If ActiveChart Is Nothing Then Exit Sub
fname = InputBox("filename")
If fname = "" Then Exit Sub
fname = ThisWorkbook.Path & "\" & fname & ".png"
ActiveChart.Export FileName:=fname, filtername:="png"
MsgBox "saved"
End Sub
Note: It might be a goof idea to also have code that checks to make sure the user did not enter any characters that cannot be used in filenames too.
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 want to copy the data from a closed file I have selected and see it in the file containing this macro.
I am using Office365.
How can i copy data from this "FullPath" workbook ?
Private Sub PathName()
Dim FullPath As String
On Error GoTo extApp
FullPath = Application.GetOpenFilename(FileFilter:="File Filter," & _
"*.xls;*.doc;*.xlsx;*.mdb;*.ppt;*.pdf", Title:="Please Select A File")
Exit Sub
extApp: Select Case Err.Number
Case 104
MsgBox ("104")
Exit Sub
Case Else
MsgBox "Runtime Error: " & Err.Number & vbNewLine & Err.Description
Stop
Resume
End Select
End Sub
You may try the following code modication, add in your other part of code to make it work as a complete sub:
Private Sub PathName()
Dim FullPath As String
Dim wb As Workbook
Application.DisplayAlerts = False
On Error GoTo extApp
FullPath = Application.GetOpenFilename(FileFilter:="File Filter," & _
"*.xls;*.doc;*.xlsx;*.mdb;*.ppt;*.pdf", Title:="Please Select A File")
Set wb = Workbooks.Open(FullPath, , True)
wb.Worksheets("Sheet1").Range("A1:B" & lastrow).Copy
Sheet1.Range("A1").PasteSpecial xlPasteValues
'
'
'
wb.Close
Application.DisplayAlerts = True
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!
I'm trying to create a macro for a command button that when clicked, will get the job number from that row and look for a file for that job. If it does not exist I want it to copy from a template and save with a new name, otherwise just open the file.
However, I cannot seem to work out how to get hold of the information for the command button that calls the macro. This is what I have so far:
Public Function ShapeExists(OnSheet As Object, Name As String) As Boolean
On Error GoTo ErrShapeExists
If Not OnSheet.Shapes(Name) Is Nothing Then
ShapeExists = True
End If
ErrShapeExists:
Exit Function
End Function
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim buttonName As String
buttonName = (Target.Row - 1)
If Not ShapeExists(ActiveSheet, buttonName) Then
If Range("O" & Target.Row).Value = "" And Target.Column <= 14 And Target.Row > 1 Then
ActiveSheet.Buttons.Add(910.5, Range("O" & Target.Row).Top, 80, 20).Select
Selection.Name = buttonName
Selection.OnAction = "Sheet1.JobButton"
ActiveSheet.Shapes(buttonName).Select
Selection.Characters.Text = "Open Job"
End If
End If
End Sub
Private Sub JobButton()
Dim newText As String
ActiveSheet.Shapes(Application.Caller).Select
If Range("N" & Selection.TopLeftCell.Row).Value <> "" Then
newText = "Job " & Range("N" & Selection.TopLeftCell.Row).Value
Dim checkFilename As String
Dim check As String
check = "N" & Selection.TopLeftCell.Row
checkFilename = newText & ".xlsm"
If Dir(checkFilename) <> "" Then
Workbooks.Open (newText)
Else
Dim SrcBook As Workbook
Set SrcBook = ThisWorkbook
Dim NewBook As Workbook
NewBook = Workbooks.Open("Job Template.xlsm")
SrcBook.Worksheets(1).Range("D" & Selection.TopLeftCell.Row).Copy
NewBook.Worksheets(2).Range("B15").PasteSpecial
With NewBook
.Title = newText
.Subject = newText
.SaveAs Filename:=newText
End With
End If
Else
ErrMsg:
MsgBox ("Job Should always have a number."), , "NO JOB NUMBER"
End If
End Sub
As you can see I am currently trying ActiveSheet.Shapes(Application.Caller).Select, this is causing a "Run-time error '13': Type mismatch".
Any help would be much appreciated, thank you!
Right-click the button --> View Code --> put your JobButton code here