If I want to save an invoice in the same folder in a different computer.
My path in my current system is C:\Users\bala\Google Drive\Invoice
I'll also be saving it C:\Users\sanford\Google Drive\Invoice
Heard that environment variables do this job, not sure how to do it.
Sub Save_As()
Dim filename As String
Dim msgResponse As VbMsgBoxResult
filename = "C:\Users\bala\Google Drive\Invoice\" & Range("F4") & Range("G4") & "_" & Range("M10")
If Len(Dir(filename)) = 0 Then
ActiveSheet.SaveAs filename, FileFormat:=52, CreateBackup:=False
Application.DisplayAlerts = True
MsgBox "Invoice saved successully", vbOKOnly, "INVOICE SAVED"
Else
msgResponse = MsgBox("Do you want to overwrite?", vbYesNoCancel)
If msgResponse = vbYes Then
ActiveSheet.SaveAs filename, FileFormat:=52, CreateBackup:=False
Application.DisplayAlerts = True
MsgBox "Invoice saved successully", vbOKOnly, "INVOICE SAVED"
Else
Exit Sub
End If
End If
End Sub
Can anyone help me out? Thanks!
You can use the Environ-function to get any system variable that is set, eg Environ("Username") to get the name of the current user.
However, be aware that the username is not always the name of the folder where all the user documents are stored. Therefore, it's better to use Environ("UserProfile"). So try:
filename = Environ("UserProfile") & "\" & Range("F4") & Range("G4") & "_" & Range("M10")
Related
My code is suppose to check cell j2 for an email address and if found, convert that specific tab to pdf and save it in a file path that the user chooses. It works fine on the original workbook I made the macro in. When I copy the code and try running it, it prints to pdf different sheets that don't even have anything in j2 with the incorrect tab name. I keep getting an Run time error 5 Invalid procedure call or argument when i run the code on the print pdf line.
Sub SaveSheetsAsPDF()
Dim DestFolder As String
Dim PDFFile As String
Dim wb As Worksheet
Dim AlwaysOverwritePDF As Boolean
'Speed up macro
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
End With
'Create new PDF file name including path and file extension
For Each wb In ThisWorkbook.Worksheets
'Test j2 for a mail address
If wb.Range("J2").Value Like "?*#?*.?*" Then
PDFFile = DestFolder & Application.PathSeparator & wb.Name & "-" & Format(Date, "mmyy") & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
End If
'Prints PDF
wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next wb
MsgBox "All Files Have Been Converted!"
ResetSettings:
'Resets optimization settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Edit: Also not all worksheets on the workbook will need to converted. So only the sheets that need to be converted will have the email address in J2.
I have the following WB code which tries to force the user to save the file as a particular file type (.xlsm) and name (the default path & "username-gaplist" --> can be followed by ANY type after this). So far I'm almost got it working down pat, except for 1 issue with the comparison operator in the IF statement.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim txtFileName As String
Dim yn As Boolean
Dim a As String
a = Application.DefaultFilePath & "\" & Environ("UserName") & "-Gaplist.xlsm"
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(Environ("UserName") & "-Gaplist", "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
'this compares the named file by user to the restriction which is username and gap list, and cancels if non-confmring
If Left(txtFileName, Len(txtFileName)) >= Left(a, Len(txtFileName)) Then
MsgBox Left(txtFileName, Len(txtFileName)) & vbLf & Left(a, Len(txtFileName))
'if user hits cancel (returns value of "False")
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbOKOnly
Cancel = True
Exit Sub
End If
'if an invalid string is entered
Else
MsgBox "Must be saved in following format:" & vbLf & Application.UserName & "-Gaplist" & " " & "(you can add whatever after this)", vbOKOnly, "Retry.."
Cancel = True
Exit Sub
End If
'3. Save the file based on string entered
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Saved to: " & txtFileName, vbExclamation, Now
End If
End Sub
Like I said, I know that the issue lies in the
Left(txtFileName, Len(txtFileName)) >= Left(a, Len(txtFileName))
and the Cancel function works correctly in this setup, but I tested and this is what happens:
Entered: username-gaplist.xlsm String(fixed): username-gaplist.xlsm
result: GOOD (will overwrite if already saved as display events gets
turned off) Entered: usernam.xlsm String(fixed):
username-gaplist.xlsm result: Good (will give the user's the msgbox
telling them to retry as it doesn't conform)
Entered: username-gaplist323423.xlsm String(fixed):
username-gaplist.xlsm result: Good (will save accordingly to the
specified file path)
Entered: userzzz.xlsm String(fixed): username-gaplist.xlsm result:
BAD - this is allowing the user to save because adding the "z" means that the entered string is > than the fixed string (based on
same length), and it saves this . I would like to fix this
Entered: (user hits cancel) String(fixed): username-gaplist.xlsm
result: Msgbox action cancelled - exits sub
The other thing I could try is to use a "LIKE" operator , but have little experience using this.
Anyone provide any thoughts/suggestions would be great!
THanks
Figured it out.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim txtFileName As String
Dim yn As Boolean
Dim a As String
a = Application.DefaultFilePath & "\" & Environ("UserName") & "-Gaplist"
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(Environ("UserName") & "-Gaplist", "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
'this compares the named file by user to the restriction which is username and gap list, and cancels if non-confmring
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbExclamation, "Cancelled.."
Cancel = True
Exit Sub
ElseIf Left(WorksheetFunction.Substitute(txtFileName, ".xlsm", ""), Len(a)) = a Then
GoTo ResumeSub
ElseIf Left(WorksheetFunction.Substitute(txtFileName, ".xlsm", ""), Len(a)) <> a Then
MsgBox "Must be saved in the following format: " & Chr(10) & Chr(10) & _
Environ("username") & "-Gaplist" & "(you can enter whatever text after this)" & vbLf & vbLf & _
"Note: Not case sensitive!", vbCritical, "Retry.."
Cancel = True
Exit Sub
End If
'3. Save the file.
ResumeSub:
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Saved to: " & txtFileName & vbLf & vbLf & Space(15) & Date & " " & Time, vbInformation, "Saved!"
End If
End Sub
Below is what I'm trying to do -
Copy data from an existing workbook and paste as text to existing word file saved on local drive
Save that file using predefined text + value defined in excel cell + today's date
It all works fine but only problem I'm facing is, I want it to give me a prompt if file name already exists such that I could take an informed decision whether or not to replace it with existing one. But it doesn't do that. It just overwrites the existing one.
Code
Sub GenerateLabelandInvoice()
'Open an existing Word Document from Excel
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Application.DisplayAlerts = True
objWord.Documents.Open "D:\path name \ file name.docx"
Range("L19:L29").Copy
With objWord
.Selection.PasteSpecial DataType:=wdPasteText
objWord.ActiveDocument.SaveAs Filename:="D:\path name\" & _
"Address Label & Invoice - " & Range("L23").Value & " " & _
Format(Date, "dd-mmm-yyyy") & ".docx", _
FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
objWord.Visible = True
objWord.Application.DisplayAlerts = True
End With
End Sub
Save the filename in a variable and then using DIR test if the file exists.
Is this what you are trying? (Untested)
Dim NewFileName As String
Dim Ret As Variant
NewFileName = "D:\path name\" & "Address Label & Invoice - " & _
Range("L23").Value & " " & _
Format(Date, "dd-mmm-yyyy") & ".docx"
If Dir(NewFileName) <> "" Then
Ret = MsgBox("File exists. Would you like to replace", vbOKCancel)
If Ret = vbOK Then
objWord.ActiveDocument.SaveAs Filename:=NewFileName, _
FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
End If
Else
objWord.ActiveDocument.SaveAs Filename:=NewFileName, _
FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
End If
I have the following code which is designed so I can quick save to my desktop and then put the file into a folder. This code works fine if the file is already saved in an .xls, .csv, .xlsx or .xlsm file extension, however, when the file IS NOT saved, I only get the pop-up message boxes, and nothing happens. I was thinking about re-structuring using a CASE STATEMENT with right(activeworkbook.name, 4), but didn't know how to structure as I am not familiar with these statements. Thank you.
Sub SavetoDesktop()
'this macro will save the activesheet into the default path giving it the current name and xlsx extension
Dim fname As String
' If Right(ActiveWorkbook.Name, 5) <> ".xlsx" And Right(ActiveWorkbook.Name, 5) <> ".xls" And _
' Right(ActiveWorkbook.Name, 5) <> ".xlsm" And Right(ActiveWorkbook.Name, 5) <> ".csv" Then
If Right(ActiveWorkbook.Name, 5) = ".xlsx" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsx", "") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .xlsx file!"
ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End If
If Right(ActiveWorkbook.Name, 4) = ".csv" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".csv", "") & ".csv"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .csv file!"
MsgBox ActiveWorkbook.Name
End If
If Right(ActiveWorkbook.Name, 4) = ".xls" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xls", "") & ".xls"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .xls file!"
End If
If Right(ActiveWorkbook.Name, 5) = ".xlsm" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .xlsm file!"
End If
' Else
'
' ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
' End If
'MsgBox Application.DefaultFilePath
'MsgBox ActiveWorkbook.Name
'
' ActiveWorkbook.SaveAs Filename:=fname
'
End Sub
thanks for the response. I tried this out and found the following: 1) The msgbox popped up when I tried saving Book1, and then it said "could not save" , and it did not save to desktop. For already saved files, I just got the "could not save" msgbox. I've never seen the "LIKE" and the "" syntax (at least in VBA, have seen in SQL). Is the like used for patterns in strings? and does the "" function as a wildcard for anything before or after? I also used a select case statement and found it was successful. I'll post below. Thanks again for the reply.
Sub SavetoDesktop()
'this macro will save the activesheet into the default path giving it the current name and xlsx extension,
' unless it already has an extension of the 4 most common formats, then it will simply save over
'(replace) the current file w a prompt
Dim fname As String
On Error GoTo errormessage
Select Case Right(ActiveWorkbook.Name, 4)
Case "xlsx"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsx", "") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=fname
Case ".xls"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xls", "") & ".xls"
ActiveWorkbook.SaveAs Filename:=fname
Case "xlsm"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=fname
Case ".csv"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".csv", "") & ".csv"
ActiveWorkbook.SaveAs Filename:=fname
Case Else
MsgBox "Saved to desktop as .xlsx file!"
ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End Select
Exit Sub
errormessage:
MsgBox "No action", vbInformation + vbOKCancel, Time()
End Sub
Is this what you are trying to do?
Sub SavetoDesktop()
'this macro will save the activesheet into the default path giving it the current name and xlsx extension
Dim fname As String
Select Case True
Case ActiveWorkbook.Name Like "*.xlsx", _
ActiveWorkbook.Name Like "*.xlsm", _
ActiveWorkbook.Name Like "*.xls", _
ActiveWorkbook.Name Like "*.csv"
fname = Application.DefaultFilePath & "\" & ActiveWorkbook.Name
Case Else
msgBox "No file extension. Will be saved as .xlsx in the Desktop folder"
fname = Environ$("HOMEDRIVE") & Environ$("HOMEPATH") & "\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End Select
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=fname
msgBox IIf(Err.Number, "Could not Save", "Saved")
Application.DisplayAlerts = True
End Sub
It is supposed to save as file name: Folder\test location 'what ever is in cell C27' and then data and time. I am getting :'008 11 2015 00 00 00'. How do I clean this up with out using "/" and ":"? Note the first 0 is just the test number I used.
Also this macro is in a template that the Testing software uses that is why it has to use Auto_open but the other problem is that when it saves as a non template file, upon opening it tries to run the macro in the non template file. How can I make it so the macro does not save in or is disabled in the save as files/ non template files?
Sub Auto_Open()
Dim FileName As String
Dim FilePath As String
Dim FileDate As String
MyNote = "Is Cell 'C27' Overview Information" & SavePath & " Location_1,2,3,or 4?"
Answer = MsgBox(MyNote, vbQuestion + vbYesNo)
If Answer = vbYes Then
FilePath = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test"
FileName = Sheets("Data").Range("C27").Text
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName
Dim FileCopyName As String
Dim FileCopyPath As String
FilePath = "C:\Users\aholiday\Desktop\Backup"
FileName = Sheets("Data").Range("C27").Text
FileDate = Format(Date, "mm dd yyyy hh mm ss")
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName & FileDate
MsgBox "File was saved!"
MyNote = "Open FRF Data Sheet?(After Forth Test Only)"
Answer = MsgBox(MyNote, vbQuestion + vbYesNo)
If Answer = vbYes Then
Workbooks.Open ("FRF_Data_Sheet_Template.xlsm")
Else
MsgBox "Ready for Next Test, Please Exit."
End If
Else
MsgBox "File was not saved, Please Use Location_1,2,3or,4 Durring SIG ATM Test"
End If
End Sub
Solved:
Sub Auto_Open()
With Range("A30")
.Value = Time
.NumberFormat = "h-mm-ss AM/PM"
End With
Dim FileName As String
Dim FilePath As String
Dim FileDate As String
MyNote = "Is Cell 'B27' Overview Information" & SavePath & " Location1,2,3,or 4?"
Answer = MsgBox(MyNote, vbQuestion + vbYesNo)
If Answer = vbYes Then
FilePath = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test"
FileName = Sheets("Data").Range("C27").Text
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName
Dim FileCopyName As String
Dim FileCopyPath As String
Dim FileTime As String
FilePath = "C:\Users\aholiday\Desktop\Backup"
FileName = Sheets("Data").Range("B27").Text
FileTime = Sheets("Data").Range("A30").Text
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName & FileTime & ".xlsx", FileFormat:=xlOpenXMLWorkbook
MsgBox "File was saved!"
MsgBox "Ready for Next Test, Please Exit."
Else
MsgBox "File was not saved, Please Use Location_1,2,3or,4 Durring SIG ATM Test"
End If
End Sub
You can't have a \ in a filename.
For the date part, use the format function. You can define the date format if you want by using "MM-dd-yyy"
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName & Format(FileDate, "MM-dd-yyyy") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Use the FileFormat:=xlOpenXMLWorkbook to save it as a workbook without macros.