I wanted to save the file which is set = Workbook open with the date, however it saves this file for me as a tmp file. Where do I go wrong?
Set wb = Workbooks.Open(MyFolder & "\" & MyFile, UpdateLinks:=0)
MyFolder1 = "\\bank.ad.pkobp.pl\dfs\DaneGrupowe\BH\BPR\Wlasne\003_Adekwatność_kapitałowa\_Beata_replacement\_KROK_4_COREP_ITS\Robocze\macro"
wb.SaveAs (MyFolder1 & Format(Date, ddmmyyyy) & ".xls"))
Solution :
Filename = "CMR_CJ_MINIMAL_"
MyFolder1 = "xxx\xxx"
wb.SaveAs (MyFolder1 & Filename & Format(Now(), "MM.YYYY") & ".xlsx")
Related
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
Background:
Several years ago, I made a spreadsheet to generate a list of samples to be tested each day. The user (usually me) checks boxes to indicate which tests' samples to list. Then the "save load sheet" button uses VBA to requery a database connection for sample information, populates the formatted list through a complex series of formulas, copies the values from the formula sheet ("Generator") to another sheet ("LoadSheet"), copies that sheet to a new workbook, and saves it with the date as filename in a folder according to year and month.
It worked pretty dependably for about 5 years, right up until a couple of weeks ago when my computer was upgraded from Windows 7 with Office 2013 to Windows 10 with Office 2016.
Problem:
Now, when I try to execute the code, I get Runtime error '1004: Copy method of Worksheet class failed."
Sub SaveAs()
'Copy to new workbook.
Sheets("LoadSheet").Copy '<---This is the line that fails.
' Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
'Save.
'If the worksheet already exists, the user will be asked whether to replace the file or not.
'If it already exists and is currently open, an error could arise.
'Hopefully that won't come up before I have time to think of a way to implement error handling.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Range("A1").Select
Sheets(1).Select
Range("A1").Select
ActiveWorkbook.Save
Application.CutCopyMode = False
ThisWorkbook.Activate
Workbooks(Format(Now, "mm-dd-yy") & "x.xlsx").Activate
End Sub
This is the code that saves the file. It fails on the line indicated.
What I've already tried:
I've tried right-clicking on the worksheet tab, clicking "Move or Copy..." and try to create a copy in a new workbook. Nothing happens. No error message, no new worksheet/book, nothing.
Same thing happens if I try to "move" rather than "copy."
If I try right-clicking and creating a copy in the same workbook, I get a new blank sheet, rather than a copy.
I tried repairing my Office installation, but that didn't help.
I read about some cases where users suspected file corruption, so I even tried manually copying the contents to a new workbook by Ctrl+A,C,V one sheet at a time, and then doing the same for the code. No effect.
I tried Sheets(Worksheets.Count).Select followed by ActiveSheet.Copy, since the sheet is the last one in the book, but of course that didn't work.
I read that it could be because the workbook needed to be saved first, so I tried ActiveWorkbook.Save before the copy. Still the same result.
I tried decompiling/recompiling the worksheet to no effect.
It worked fine on Windows 7 with Office 2013 (and still does on a co-worker's Win7/Excel2013 machine), but I couldn't find anything online about problems with the Sheets.Copy method in Excel 2016, so I don't know if either of those is relevant.
Any ideas?
EDIT: I've tried it on an identical computer (also running Windows 10 & Office 2016) and had the same result. I'm not sure how commonly an installation becomes corrupted, but this feels like more than coincidence. The other computer is rarely used by anyone, and it's being used primarily to run an instance of SQL Server Express and a Windows service I wrote, so I suspect that makes corruption even less likely.
I've got a workaround for now... I just save the file with the filename and path I would have used for the copy, then do a For Each on each worksheet, deleting anything not named "LoadSheet."
Sub SaveAs()
On Error GoTo SaveAs_Err
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
' Turn off alerts. They're annoying. I don't care if it's poor form, I just want to be done with this. I'm not being paid to write code.
Application.DisplayAlerts = False
'Save, disregarding consequences.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Remove extraneous sheets.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "LoadSheet" Then ws.Delete
Next
Application.DisplayAlerts = True
Exit Sub
SaveAs_Err:
Application.DisplayAlerts = True
MsgBox ("An error occurred while saving the file.")
Debug.Print "Error " & Err.Number & ": " & Err.Description
End Sub
I'm still interested in fixing the root cause of this problem, so if anyone has ideas, I'm all ears! I'll probably still try the uninstall/reinstall, but I don't expect it to change anything.
Brute force fix, try:
Sub SaveAs()
Dim newWB as Workbook, i as Integer, copyRange as Range, fName as String
Set newWB = Workbooks.Add
While newWB.Worksheets.Count > 1
newWB.Worksheets(newWB.Worksheets.Count).Delete
Wend
newWB.Worksheets(1).Name = "LoadSheet"
' get a handle on the sheet's usedRange object
Set copyRange = ThisWorkbook.Worksheets("LoadSheet").UsedRange
' assign the values to the newWB.Worksheets(1)
'newWB.Worksheets(1).Range(copyRange.Address).Value = copyRange.Value
copyRange.Copy Destination:=newWB.Worksheets(1).Range(copyRange.Address)
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
newWB.SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks.Open(fName)
End Sub
Alternatively, use the SaveAs method of the Worksheets class:
Sub SaveAs()
Dim fName as String
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
ThisWorkbook.Worksheets("LoadSheet").SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Save
Application.CutCopyMode = False
Workbooks.Open(fName)
End Sub
I've also revised both solutions to avoid the potential error you comment:
If it already exists and is currently open, an error could arise.
I would work with your IT and/or MS support on the specific failure of the .Copy method, though, it's almost certainly a problem with your installation and may result in nastier errors in the future.
I am running below code but unable to save opened notepad file in same format, code is below
Dim mytxtfile
Dim flname, flname2 As String
flname = Dir(ThisWorkbook.path & "\" & "myfile.csv")
flname2 = ThisWorkbook.path & "\" & "myfile_1.txt"
mytxtfile = Shell("C:\WINDOWS\notepad.exe " & ThisWorkbook.path & "\" & flname, 1)
AppActivate mytxtfile
SendKeys "%(FAX)", True
Application.Wait TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 2)
SendKeys "%S", True '
"Save as" dialog box opens here, but now I want to give the file name which is in flname2 i.e (myfile_1.txt) and then save and close notepad.
Copy the file using the File System Object:
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile ThisWorkbook.path & "\" & "myfile.csv", ThisWorkbook.path & "\" & "myfile_1.txt"
Basically, I'd like to save some worksheets into separate new workbooks in the same system location as original notebook I am deriving from.
I recognize that the default path is to save something new is to the location of the current notebook, but perhaps since I am opening a new workbook the default reverts to the user's Document's folder, which is where they are saving right now.
I "learned" VBA over the last couple of days, so advice on other things you notice is cool too, but the saveas is what's bothering me.
Dim ws As Worksheet
Dim wb As Workbook
Dim dept_array As Variant
Dim dept As Variant
' Add or remove a department name spelled exactly as it is in the filter
dept_array = Array("HR", "IT", "Marketing", "Product Marketing", "Sales", "Channels", "Presales", "Direct", "Sales Ops", "R&D", "Support", "G&A")
Application.ScreenUpdating = False
For Each ws In Workbooks("Weekly Department Transaction Report.xlsm").Worksheets
For Each dept In dept_array
If Application.Proper(ws.Name) = Application.Proper(dept) _
Then
Set wb = Workbooks.Add
ThisWorkbook.Sheets(dept).Copy Before:=wb.Sheets(1)
wb.Saveas dept & "_" & Format(Now, "yyyymmdd") & ".xlsx"
Workbooks("Weekly Department Transaction Report.xlsm").Sheets("Codes").Copy After:=Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Sheets(dept)
Workbooks("Weekly Department Transaction Report.xlsm").Sheets("How").Copy Before:=Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Sheets(dept)
Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Save
End If
Next dept
Next ws
Application.ScreenUpdating = True
End Sub
Please let me know if I am not following the correct stackoverflow format.
Longtime user first time asker :)
Edit this line in your code:
wb.SaveAs FileName:= ThisWorkbook.Path & "\" & dept & "_" & Format(Now, "yyyymmdd") & ".xlsx"
I am trying to write some code that will save several tabs as a pdf document in folder specified by files within excell. I would like for cells within the document to dictate where this file is saved. I am not sure if this is possibly, but if it is any help would be good! I am currently getting a Run-time error '1004' during the save process of my code.
And yes, I do have the folders created that are being referenced.
Sub asdf()
Dim Fname As String
Dim Fpath As String
Dim YrMth As String
Fname = Sheets("Sheet1").Range("A1").Text
YrMth = Sheets("Sheet1").Range("A2").Text & "\" & Sheets("Sheet1").Range("A3").Text
Fpath = "C:\Documents and Settings\My Documents\" & YrMth & "\Group\" & Fname & ".pdf"
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet4")).Select
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fpath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
Your code works for me, but not with the path you've specified.
Declare a new string variable:
dim myDocsPath as String
Get the path using:
myDocsPath = Environ$("USERPROFILE") & "\My Documents\"
and then change your definition for Fpath to:
Fpath = myDocsPath & YrMth & "\Group\" & Fname & ".pdf"
If I change the end of myDocsPath to & "\My foo Documents\" I get the same 1004 error you are getting.
Try replace line in your code
Fpath = "C:\Documents and Settings\My Documents\" & YrMth & "\Group\" & Fname & ".pdf"
with
Dim WshShell As Object
Dim MyDocsFolder As String
Set WshShell = CreateObject("WScript.Shell")
MyDocsFolder = WshShell.SpecialFolders("MyDocuments") & "\"
Fpath = MyDocsFolder & YrMth & "\Group\" & Fname & ".pdf"
Edit:
The core of this solution is in line:
MyDocsFolder = WshShell.SpecialFolders("MyDocuments") & "\"
which returns system path to My Documents, irrespectively from local system settings like language or nonstandard location of My Documents folders. Then it adds a backslash at the end.
It is more elegant (and the code becomes more portable) if you ask system about special folders than hardcode such data in your script.
More on Windows special folders in VBA you can find https://www.rondebruin.nl/win/s3/win027.htm