I'm trying to make an Excel VBA macro to automate my saves. So if it is 2022 or 2023 and it is either the month of January, February, march, etc. The file will save in that year's folder and under that month's folder. However, I'm not the best at If, Then, Else statements. I made this VBA and it doesn't work after I tried to make it create folders if they don't exist.
Sub auto-organize-save()
'
' auto-organize-save Macro
'
'
'this is for date
Dim dateOne As Date
'This is for making new folder
Dim fdObj As Object
Application.ScreenUpdating = False
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists("C:\temp\april") Then
If dateOne = April Then
ActiveWorkbook.SaveAs Filename:= _
"C:\temp\april\save3.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Else
fdObj.CreateFolder ("C:\temp\april")
End If
End If
End Sub
i modified it a bit further and I'm getting results but i need to figure out how to change the name of the folder to display the following:
"04 - APR" - 4 means the 4th month and APR is the abbreviated version. With the help of the user trincot following works perfectly.
Sub auto_organize_save1()
Dim fdObj As Object
Dim folder As String
Set fdObj = CreateObject("Scripting.FileSystemObject")
folderYear = "C:\temp\" & Format(Now, "YYYY") & "\"
folderMonth = "C:\temp\" & Format(Now, "YYYY") & "\" & Format(Now, "MM-MMM") & "\"
If Not fdObj.FolderExists(folderYear) Then
MkDir folderYear
End If
If Not fdObj.FolderExists(folderMonth) Then
MkDir folderMonth
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=folderMonth & "example2.xlsx"
Application.DisplayAlerts = False
End Sub
Some issues:
Your code is not getting a particular date, it just uses the default value of dateOne. Instead use Now.
dateOne = April references an undefined variable April. In order to get the month of a date, use the Month function, and compare it with a number.
Hard coding months, like "April", is not going to give you elegant code. Moreover, this is not even the format you are asking for ("4 - APR").
I would suggest to prefix the month 4 with a zero so it always has two digits, and will look better when other entries are "12 - DEC", ...etc.
Application.ScreenUpdating = False should only be used when you already have well working code. Don't use it for as long your code is not working. And if you use it, add also the opposite: Application.ScreenUpdating = True
I'm not sure it is a good idea to call your file always "save3", but as I got no information about this aspect, I just left it as you had it.
Here is some code you could use:
Sub auto_organize_save()
Dim fdObj As Object
Dim folder As String
Set fdObj = CreateObject("Scripting.FileSystemObject")
folder = "C:\temp\" & Format(Now, "MM-MMM") & "\"
If Not fdObj.FolderExists(folder) Then
MkDir folder
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=folder & "save3.xlsx"
Application.DisplayAlerts = True
End Sub
Related
I have an Excel project reporting system which uses Excel VBA. The report files are created on a monthly basis, i.e one file for January, one for February etc. At the end of each month I use a macro in Book 1 to open a template file and then carry forward summary data from the current month into the new month's report file(Book 2).
At the end of the Book 1 macro routine it resets the date, on one of the Book 2 worksheets(to the 1st of the month) and herein lies my problem, the cell, into which this date is entered, is linked to a Book 2 macro that runs when this date changes.
By using 'Application.AutomationSecurity = msoAutomationSecurityForceDisable' at the start of the Book 1 macro I have managed to stop the Book 2 macro running, so far so good.
After resetting the date I use 'Application.AutomationSecurity = PreviousSecurity', where Previous Security is a variable containing the initial state of the AutomationSecurity before it was disabled.
The macro concludes with no problem and brings the Book 2 file to the foreground, at this point the user needs to manually run a Book 2 macro, to update a logo, but even though I have reset the Automation Security I cannot run macros in Book 2 until the file has been closed and re-opened.
The relevant bits of the Book 1 macro are:
Sub NewCarryFwd3()
Dim Folder As String, CFileName As String
' The 'NewClient' and 'NewProject' variables are defined as Public at head of module
' Get file names
Folder = ActiveWorkbook.Path
CFileName = ActiveWorkbook.Name
' Stop Excel screen updating
Application.ScreenUpdating = False
' Stop autocalculation of formulae to speed up procedure
Application.Calculation = xlCalculationManual
'**********
'Prevent Macros in the new Template running
Dim previousSecurity As MsoAutomationSecurity
PreviousSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
'**********
' Calculate new DRS month dates
Dim OldDate As Date, NewDate As Date, NewMonth As String
OldDate = Workbooks(CFileName).Sheets("Setup").Range("Month_start").Value
NewDate = DateAdd("m", 1, OldDate)
NewMonth = Choose(Month(NewDate), "Jan", "Feb", "Mar", "Apr", "May", "June", "July", "Aug", "Sept", "Oct", "Nov", "Dec")
' Open New DRS File from Microsoft user's template folder
Dim NextDRS As String
Workbooks.Add template:= _
"C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Templates\Oasis 3D DRS_V3.xltm"
NextDRS = ActiveWorkbook.Name
'******************************************************************************
**' My Code to update the summary data goes in here - too much to include!**
**' After updating Summary data the macro ends as below**
'******************************************************************************
' Set initial Weekly date to first day of new month?
' Set first weekly data
Workbooks(NextDRS).Sheets("Weekly").Range("WkDay7").Value = NewDate
Sheets("Weekly").Protect Sheets("Weekly").Protect
' Allow macros in New workbook to run
Application.AutomationSecurity = PreviousSecurity
' Create New file Name
Dim NewFilename As String
NewFilename = Folder & "\DRS " & Workbooks(CFileName).Sheets("Setup").Range("C2").Text & " " & NewMonth & ".xlsm"
Workbooks(NextDRS).Activate
Sheets("Daily Report").Select
' Check if new file name already exists if so add numeric ID
Dim f As Long
f = 1
Do While Dir(NewFilename) <> ""
NewFilename = Folder & "\DRS " & Workbooks(CFileName).Sheets("Setup").Range("C2").Text & " " & NewMonth & " " & f & ".xlsm"
f = f + 1
Loop
'**********
' Save new workbook for next month in Excel 2007 xlsm format.
Workbooks(NextDRS).SaveAs FileName:= _
NewFilename _
, FileFormat:=52, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=True
' Re-activate screen updating & autocalculation
Application.ScreenUpdating = True
End Sub
Is their some way to reenable the AutomationSecurity so that the Book 2 macros can be run without having to close and reopen the file?
I'd like to create several new workbooks. The VBA code below runs fine with Excel 365 and 2010. BUT with Excel 2013 or 2016, it runs fine the first time (and create the files)... and on the second run, Excel crashes without any error message.
If I run it step by step, I see that it's the SaveAs line that causes the crash.
I tried to kill the file before saving, too. To use a timer...
I tried to repair Office, to rename a HKEY (Identities), I tried to run it on 2 different windows (7 or 10). Nothing helps :/
Sub ExtraireType()
Dim shVentes As Worksheet
Dim rngVentes As Range
Dim rngTypes As Range
Dim shNew As Worksheet
Dim wkbNew As Workbook
Dim strPath As String
Dim zaza As Range
Application.DisplayAlerts = False
Set shVentes = ThisWorkbook.Worksheets("Ventes")
Set rngVentes = shVentes.Range("A1").CurrentRegion
Set rngTypes = ThisWorkbook.Worksheets("Liste").Range("A2:A4")
strPath = ThisWorkbook.Path
For Each zaza In rngTypes
rngVentes.AutoFilter
rngVentes.AutoFilter field:=3, Criteria1:=zaza.Value
rngVentes.Copy
Set shNew = ThisWorkbook.Worksheets.Add
shNew.Paste
Application.CutCopyMode = False
shNew.Move
Set wkbNew = ActiveWorkbook
wkbNew.SaveAs strPath & "\Type" & zaza.Value & Format(Date, "yyyymmdd")
wkbNew.Close
Set shNew = Nothing
Set wkbNew = Nothing
Next zaza
Set rngVentes = Nothing
Set shVentes = Nothing
Set rngTypes = Nothing
Application.DisplayAlerts = False
End Sub
This code runs well with Excel 2010 or 2019/365. But I have to use it with 2013 or 2016 :(
What am I doing wrong? Thanks for any help !
I was having this problem as well and have found a workaround - use .SaveCopyAs instead.
In the below example, .SaveAs crashes Excel every second time if I've left the Excel spreadsheet open and deleted the resultant file, whilst .SaveCopyAs saves every time irrespective. The only difference between the two is that .SaveAs has more options for how to save whereas .SaveCopyAs's only option is the filename.
Private Sub SaveAsExcelFile(TempExcelFile As Workbook, _
NewFullFileName as string, _
Optional FileFormat As XlFileFormat = xlOpenXMLWorkbook, _
Optional CreateBackup As Boolean = False)
'
' created & last edited 2020-03-06 by Timothy Daniel Cox
'
' For this example it is assumed the new file name is valid and in .xlsx format
'
Dim NewFullFileName2 as string
NewFullFileName2 = Replace(NewFullFileName, ".xlsx", "2.xlsx")
Application.EnableEvents = False
TempExcelFile.SaveCopyAs Filename:=NewFullFileName 'doesn't crash here on 2nd run
TempExcelFile.SaveAs Filename:=NewFullFileName2, FileFormat:=FileFormat, _
CreateBackup:=False 'will crash here on 2nd run
Application.EnableEvents = true
End Sub
I still think there is a bug in Excel regarding the .SaveAs however:
There's a long thread at
https://chandoo.org/forum/threads/worksheet-save-as-to-new-workbook-crashes-excel-on-second-run.40136/#post-241024
which after meandering has an apparent resolution as linked but - having
downloaded the file to see what changes have been made - he only
appears to have changed the output directory and removed a
conflicting fileformat which was set. IMO it did not resolve the
issue.
There's another similar unsolved thread at https://www.reddit.com/r/excel/comments/58fqlg/my_vba_code_works_at_first_but_if_used_twice_in_a/ which has no useful answers.
The one of the reasons that your code crash (it crushed in my case, Excel 2016), might be because you didn't add file extension at the end of:
wkbNew.SaveAs strPath & "\Type" & zaza.Value & Format(Date, "yyyymmdd")
so it might be like:
wkbNew.SaveAs strPath & "\Type" & zaza.Value & Format(Date, "yyyymmdd") & ".xlsx"
Hope it helps.
Not sure why I am getting this error. Please assist in correcting and also, provide a good explanation for the reason. I have 3 subs (from 2 modules) that call each other sequentially. Is the reason for the error message because the file name from the first sub is declared as a variable in the third sub? See code below:
Module1:
Option Explicit
Sub PRM_1_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_1_New As Workbook ' This is BCRS-PTASKS Unassigned.csv
Set PRM_1_New = Workbooks("BCRS-PTASKS Unassigned.csv")
Dim SaveDir1 As String, prmAfn As String
SaveDir1 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir1, vbDirectory)) = 0 Then MkDir SaveDir1
prmAfn = SaveDir1 & "\PRM_1_TEMP"
Application.SendKeys ("~")
PRM_1_New.SaveAs Filename:=prmAfn, FileFormat:=xlOpenXMLWorkbook
PRM_1_New.Close False
Call PRM_2_Report_Save
Application.ScreenUpdating = True
End Sub
Sub PRM_2_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_2_New As Workbook ' This is Problem WGM & WGL xref with description.xls
Set PRM_2_New = Workbooks("Problem WGM & WGL xref with description.xls")
Dim SaveDir2 As String, prmBfn As String
SaveDir2 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir2, vbDirectory)) = 0 Then MkDir SaveDir2
prmBfn = SaveDir2 & "\PRM_2_TEMP"
Application.SendKeys ("~")
PRM_2_New.SaveAs Filename:=prmBfn, FileFormat:=xlOpenXMLWorkbook
PRM_2_New.Close False
Application.ScreenUpdating = True
Call Open_PRM_Files
End Sub
Module 2:
Option Explicit
Sub Open_PRM_Files()
'
Application.ScreenUpdating = False
Dim PRM_Dir As String
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
Application.ScreenUpdating = True
End Sub
This line from the sub in Module2 is where the debugger shows the error (which is also commented in the sub above):
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
The purpose of the code here is to save two imported reports into .xlsx format, close them, and then open the files in the saved format. I need this to occur in separate subs (save and open) for other workflow processes of this VBA Project not listed (or relevant) here.
EDIT: I should also mention that the first two subs execute and provide the intended results which is each file saved in the new directory and with the proper extension.
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
This line assumes that you already have an open workbook with that name. If Excel does not find an open workbook with that name then you will get a runtime error as you noticed.
I'm assuming that you are trying to open the workbooks here which you created in the first two subs:
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
"& PRM_1_TEMP" is the name of a Workbook variable, and you're trying to concatenate it as a string name. Change this to a string matching the filename, and then move your declarations of workbooks to below the code that opens the workbooks. This way Excel opens the workbooks BEFORE trying to access them in the Workbooks collection, and you should not receive an error. I haven't tested this modification, but please let me know if it works for you.
Sub Open_PRM_Files()
Application.ScreenUpdating = False
Dim PRM_Dir As String
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_1_TEMP"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_2_TEMP"
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
Application.ScreenUpdating = True
End Sub
I have a code in excel VBA that saves a workbook with a coded path and filename which works perfectly on my computer at home running windows 8 and office 2013.
When I try to use it on my work computer which runs windows XP and office 2003 it ignores the coded path and file name and opens the save as dialogue box which defaults to the My Documents directory.
The intent is for the users at work to click save and the file will automatically go to a network drive with a personalised filename. They should not have to select a path or filename.
I have been testing with the path C:\Temp\ and saving a plain .XLS file which should work on both versions of Excel.
I tried it without disabling alerts and it gave no clues as to why it ignores the path and filename. I have also tried fileformat:=xlnormal etc. with no luck.
Why is this happening and how do I fix it?
Here is the code:
Sub FeedBackSave()
' Save the Feedback worksheet created by the user to the network drive using the path copied from
' the Management workhseet cell A11, the resource name copied from cell A1 and todays date as the filename.
Dim wsh As Worksheet
Dim nme, pth, TodaysDate As String
TodaysDate = format(Now, "dd-mm-yy")
nme = Range("A1").Value
pth = Worksheets("Management").Range("A11").Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False ' Prevents alerts like incorrect file type or overwrite file y/n to permit 1 click save
'Save Feedback worksheet
ActiveWorkbook.Close SaveChanges:=True, Filename:=pth & "FeedBack " & nme & " " & TodaysDate & ".xls"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Saveas Before you close the workbook, might help., check the ranges, not sure if they are on the same sheet or not.
Sub FeedBackSave()
' Save the Feedback worksheet created by the user to the network drive using the path copied from
' the Management workhseet cell A11, the resource name copied from cell A1 and todays date as the filename.
Dim wsh As Worksheet
Dim nme As String, pth As String, TodaysDate As String, FName As String
Set ws = Worksheets("Management")
TodaysDate = Format(Now, "dd-mm-yy")
nme = Range("A1").Value
pth = ws.Range("A11").Value
FName = pth & nme & "-" & TodaysDate & ".xls"
Application.DisplayAlerts = 0
With ActiveWorkbook
.SaveAs FileName:=FName
.Close
End With
End Sub
I have a spreadsheet that exports saved invoices. the export works perfectly. however, i want to ONLY export data for the previous week. the last cell in the workbook has the last saved date in it. i want to search through the column to find the last saved date within the previous 7 days, and create an export csv file with just that data.
here is what i have so far.
Sub CopyToCSV()
Dim MyPath As String
Dim MyFileName As String
Dim Region As Variant
Application.ScreenUpdating = False
Sheets("Invoice").Activate
Region = Range("E5").Value
Sheets("Stored Invoices").Activate
MyPath = Application.ActiveWorkbook.Path
MyFileName = "Region" & Region & "-" & Format(Date, "ddmmyy")
'Makes sure the path name ends with "\":
MyPath = MyPath & "\"
'Makes sure the filename ends with ".csv"
MyFileName = MyFileName & ".csv"
'Copies the sheet to a new workbook:
Sheets("Stored Invoices").Copy
'The new workbook becomes Activeworkbook:
With ActiveWorkbook
'Saves the new workbook to given folder / filename:
'MyPath &
.SaveAs Filename:=MyPath & MyFileName, FileFormat:=xlCSV, CreateBackup:=False
'Closes the file
.Close False
End With
End Sub
any help would be greatly appreciated!
Becky
Assuming the data is in order:
Loop through each cell in the column containing the date, and evaluate said date. Have it loop until it encounters a date more than 7 days before the current data. Have a counter in the loop that counts how many rows it looped though. then, its simply Range("A1", Cells(countedrows, Numcolumns)).copy DestinationRange assuming the data starts in a1, so the range would be from A1 down to the last counted row in the last column, and then you move that to a new Sheet/book, and save that
there be the logic, Edit your post with your new code and comment if you get stuck
HTH