I can't figure out how to delete these excel files programmatically, say when they are 5 days(5 working days) old or older. I was able to figure out how to delete them if they are 5 days older then current date but the weekends and holiday, etc. leave some
undeleted.
Any help will be greatly appreciated,
here is code for backup excel files.
Dim backupfolder As String
backupfolder = "E:/CLIENTS/ExcelBackup/BackupJM/"
Dim savedate
savedate = Date ' Current system date
Dim savetime
savetime = Time ' Current system time
Dim formattime As String
formattime = Format(savetime, "hh.mm.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD-MM-YYYY")
Application.DisplayAlerts = False
'Application.Run ("Auto_Save")
ActiveWorkbook.SaveCopyAs fileName:=backupfolder & formatdate & " " & formattime & " " &
ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
MsgBox "Backup Run. Please Check at: " & backupfolder
Related
I have a file I want to pickup from the previous wednesday June 10th. I will be running my code today (Sunday June 14th). However this will reoccur every week.
Is there a way I can make my code dynamic enough to pickup the previous wednesday date?
Here is my code Set wbTarget = Workbooks.Open("C:\extract\Business_Report_20200527.xlsx")
Can I alter that path to dynamically pickup a date?
Thank you.
Try this:
Dim today As Date
Dim IntervalType As String
Dim FilePath As String
today = Date()
IntervalType = "d"
While Weekday(today) <> vbWednesday
today = DateAdd(IntervalType, -1, today)
Wend
FilePath = "C:\extract\Business_Report_" + Format(today, "yyyymmdd") + ".xlsx"
Set wbTarget = Workbooks.Open(FilePath)
Another way to do it:
Sub Test()
MsgBox "Last Wednesday: " & PreviousWednesday & vbCr & _
"Wednesday prior to 9th June: " & PreviousWednesday(DateValue("9 June 2020")) & vbCr & _
"Last Wednesday formatted: " & Format(PreviousWednesday, "yyyymmdd")
'Your code:
'Set wbTarget = Workbooks.Open("C:\extract\Business_Report_" & Format(PreviousWednesday, "yyyymmdd") & ".xlsx")
End Sub
Public Function PreviousWednesday(Optional CurrentDate As Date) As Date
If CurrentDate = 0 Then CurrentDate = Date
PreviousWednesday = (CurrentDate - Weekday(CurrentDate, vbMonday) + 1) - 5
End Function
I want to create multiple saves of the same word file using visual basic. each file will need to be named with the day of the month and month name (not numbers) i want this to run from the 1 to 31 on each month. i have a rough code,
Sub Mine()
Dim DateStr, FileStr As String
DateStr = Format$(Date, "DD")
FileStr = DateStr & ".docx"
ActiveDocument.Save
ChangeFileOpenDirectory "Z:\FIR MASTER FOLDER\FCR briefing sheet\2018\Test"
ActiveDocument.SaveAs2 FileName:=FileStr, FileFormat:=wdFormatXMLDocument
End Sub
now how do i add the loop and the day and month format part
try the below. If you want in the format you mention in comment simply put as
Debug.Print monthName & " " & i
Saving to different folders in an amendment to your original question. I am happy to update but this should deal with your initial question as posed.
It works with the current month. You would want a test to make sure doesn't already exist. I tried to show you each of the functions you might consider and how you could structure a loop.
Uses a function from here for end of month.
Sub test()
Dim myDate As Date
Dim myMonth As Long
myDate = Date
Dim monthName As String
monthName = Format$(myDate, "mmmm")
Dim endOfMonth As Long
endOfMonth = CLng(Format$(dhLastDayInMonth(myDate), "dd"))
Dim i As Long
For i = 1 To endOfMonth
Debug.Print monthName & " " & i
Next i
End Sub
Function dhLastDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInMonth = DateSerial(Year(dtmDate), _
Month(dtmDate) + 1, 0)
End Function
So save with the filename you would do something like:
For i = 1 To endOfMonth
ActiveDocument.SaveAs fileName:= "C:\Test\" & monthName & " " & i, FileFormat:=wdFormatXMLDocument
Next i
Reference:
http://www.java2s.com/Code/VBA-Excel-Access-Word/Word/TosaveadocumentwithanewnameusetheSaveAsmethod.htm
Or to create folders for the year:
Sub AddFoldersAndFiles()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Dim fso As FileSystemObject ' ''early binding. Requires reference to MS Scripting runtime
'Set fso = New FileSystemObject ''early binding
Dim myYear As Long
Dim endOfMonth As Long
Dim filePathStub As String
filePathStub = "C:\Users\User\Desktop\" ' path to create folders at
myYear = Year(Date)
Dim monthsArray() As Variant
monthsArray = Array("January","February","March","April","May","June","July","August","September","October","November","December")
Dim currentMonth As Long
For currentMonth = LBound(monthsArray) To UBound(monthsArray)
Dim folderName As String
folderName = filePathStub & monthsArray(currentMonth) & CStr(myYear)
folderName = fso.CreateFolder(FolderName)
endOfMonth = CLng(Format$(dhLastDayInMonth(DateSerial(myYear,currentMonth + 1, 0)),"dd"))
Dim currentDay As Long
For currentDay = 1 To endOfMonth
ActiveDocument.SaveAs2 FileName:= folderName & Application.PathSeparator & monthsArray(currentMonth) & " " & currentDay, FileFormat:= wdFormatXMLDocument
Next currentDay
Next currentMonth
End Sub
I'm trying from Excel to scan a shared inbox for emails with attachments, which were received on a certain date. The aim is to save the attachments and import them into the workbook running the code.
Here's the code I have so far adapted from Download attachment from Outlook and Open in Excel to scan the inbox and print some info on the emails it finds
Sub extractEmailDetails()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object, oOlInp As Object
Dim oOlItm As Object
Dim strDateFrom As String, strDateTo As String
Dim searchDate As Date
searchDate = #12/9/2015# 'mm/dd/yyyy
strDateFrom = "'" & Format(searchDate, "dd/mm/yyyy") & "'"
strDateTo = "'" & Format(searchDate + 1, "dd/mm/yyyy") & "'"
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInp = oOlns.Folders("SHR-Cust Ops MI Team Inbox")
Set oOlInb = oOlInp.Folders("Inbox")
'~~> Store the relevant info in the variables
For Each oOlItm In oOlInb.Items.Restrict("[attachment] = True AND [receivedTime] > " & strDateFrom & " AND [receivedTime] < " & strDateTo)
Debug.Print oOlItm.ReceivedTime & " " & oOlItm.Subject
Next
End Sub
When I search for the 8th of December it only brings back emails that were received after 8am.
I changed the settings for working hours in the calendar to midnight to midnight (no working hours) and the code then brought back all emails for the specified date. However, I can't leave my calendar with no working hours. Is there a way to change the default behaviour to ignore the working hours?
It sure sounds like your are getting GMT + your local time zone offset.
What is your TZ?
After messing around with this a little I've found a solution. A very obvious one. You can't just provide the date, you also need to provide a time, so:
[...]
strDateFrom = "'" & Format(searchDate, "dd/mm/yyyy") & "'"
strDateTo = "'" & Format(searchDate + 1, "dd/mm/yyyy") & "'"
Becomes
[...]
strDateFrom = "'" & Format(searchDate, "dd/mm/yyyy hh:mm") & "'"
strDateTo = "'" & Format(searchDate + 1, "dd/mm/yyyy hh:mm") & "'"
I would like to open an Excel file which has a date variable at the end. To date I have created an okay code to retrieve the file based on working backwards from the current date. I would prefer a userform or input box to specify the exact date needed. The date is in the ddmmyyyy format and is at the end of the filename. Any help is much appreciated.
Sub OpenLatest()
---Opens a sheet based on date, searches backward from today til it finds a matching date
Dim TestDate As Date
Dim StartWB As String
Const sPath As String = "C:\Users\Laurence\Documents\"
Const dtEarliest = #6/1/2015# '--to stop loop if file not found by earliest valid date.
TestDate = Date
StartWB = ActiveWorkbook.Name
While ActiveWorkbook.Name = StartWB And TestDate >= dtEarliest
On Error Resume Next
Workbooks.Open sPath & "Firstmacro_dtetime1 " & Format(TestDate, "ddmmyyyy") & ".xlsx"
TestDate = dtTestDate - 1
On Error GoTo 0
Wend
If ActiveWorkbook.Name = sStartWB Then MsgBox "Earlier file not found."
End Sub'
You can use the InputBox() function to request a date from the user.
Dim strDate As String
strDate = InputBox("Enter a date:")
If Not IsDate(strDate) Then
MsgBox "Not a date"
Exit Sub
End If
' Create the file path...
Dim strPath As String
strPath = "C:\Users\Laurence\Documents\Firstmacro_dtetime1 " & Format$(strDate, "ddmmyyyy") & ".xlsx"
' Make sure it exists...
With CreateObject("Scripting.FileSystemObject")
If .FileExists(strPath) Then
Workbooks.Open strPath
End If
End With
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"