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
Related
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
When I use restrict to set the date range on an Outlook item object, it does not pick up any appointments before whatever I have set as my "Work Hours" on Outlook. How do I make whatever the user sets as "Work Hours" not influence my macro?
Eg. My "Work Hours" in Outlook is set to 1PM to 5PM. I create 4 appointments:
1111 at 10AM Sept 4, 2017
2222 at 1PM Sept 4, 2017
3333 at 6PM Sept 4, 2017
4444 at 1PM Sept 5, 2017
My code will pick up the last 3 appointments, but not the first, if the dates I enter are 9/4/2017 and 9/5/2017.
Sub restrictDemo()
Dim olkItems As Outlook.Items, _
olkSelected As Outlook.Items, _
olkAppt As Outlook.AppointmentItem, _
dateStart As Date, _
dateEnd As Date
dateStart = InputBox("Starting date?", "", "m/d/yyyy")
dateEnd = InputBox("Ending date?", "", "m/d/yyyy")
If IsDate(dateStart) And IsDate(dateEnd) Then
Set olkItems = Session.GetDefaultFolder(olFolderCalendar).Items
olkItems.IncludeRecurrences = True
olkItems.Sort "Start"
Set olkSelected = olkItems.Restrict("[Start] >= '" & dateStart & "' AND [Start] <= '" & dateEnd & "'")
For Each olkAppt In olkSelected
counter = counter + 1
MsgBox counter
MsgBox olkAppt.Subject & " " & olkAppt.Location & olkAppt.Start
Next
Else
MsgBox "You must enter valid starting and ending dates to run this macro.", vbCritical + vbOKOnly, MACRO_NAME
End If
End Sub
Use the format expected by Restict. https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/items-restrict-method-outlook
Sub restrictDemo()
Dim Counter As Long
Dim olkItems As items
Dim olkSelected As items
Dim olkAppt As AppointmentItem
Dim dateStart
Dim dateEnd
Dim StrFilter As String
' You may need to use a different date format.
dateStart = InputBox("Starting date?", , "2017-08-22")
dateEnd = InputBox("Ending date?", , "2017-08-23")
If IsDate(dateStart) And IsDate(dateEnd) Then
Set olkItems = Session.GetDefaultFolder(olFolderCalendar).items
olkItems.IncludeRecurrences = True
olkItems.Sort "Start"
'StrFilter = "[Start] >= '" & dateStart & "' AND [Start] < '" & dateEnd & "'"
'Debug.Print StrFilter
StrFilter = "[Start] >= '" & Format(dateStart, "ddddd h:nn AMPM") & "'"
Debug.Print StrFilter
StrFilter = StrFilter & " AND [Start] < '" & Format(dateEnd, "ddddd h:nn AMPM") & "'"
Debug.Print StrFilter
Set olkSelected = olkItems.Restrict(StrFilter)
For Each olkAppt In olkSelected
Counter = Counter + 1
Debug.Print Counter & ":" & olkAppt.Subject & " " & olkAppt.location & olkAppt.start
'MsgBox Counter & ":" & olkAppt.Subject & " " & olkAppt.location & olkAppt.start
Next
Else
MsgBox "Enter valid starting and ending dates.", vbCritical + vbOKOnly, "MACRO_NAME"
End If
End Sub
The deeper question of why a day begins at the start of a work day and continues for 24 hours remains unanswered.
I have an Access database that is tracking a rolling 35 week window on job data. I have it automated so once a month I run a script that generates an e-mail and attaches an Excel worksheet for the appropriate program manager so they can update their crew number count projections for the next 35 weeks. The program saves a copy of the Excel sheet so I can run a compare once the sheet has been returned.
What I would like to do is add in the missing dates from their dataset prior to building the Excel sheet that gets e-mailed. That way the table where I store the dates would have an auto-generated line item number that I could reference later when I re-import the data from the Excel file.
I suppose I could just run an update query that expands all of the job records in the database to the same end date and later purge out anything that has a zero crew count as the rolling window drops away, but is there was a better way of approaching this?
The following code will:
1. Add missing dates (but only if within 4 weeks of run date)
2. Add 35 new 'week' records to past the current date
This code requires your table design to have a Unique Key of Job_ID + WeekDate
Option Compare Database
Option Explicit
Dim dbs As DAO.Database
Dim rsJobs As DAO.recordSet
Dim rsWeek As DAO.recordSet
Function Create_New_Weeks()
Dim strSQL As String
Dim i As Integer
Dim dStartDate As Date
Dim dEndDate As Date
Dim dPriorMonday As Date
Dim dTempDate As Date
Dim strJobID As String
Const iWksToAdd = 35 ' Change as desired
On Error GoTo Error_Trap
Set dbs = CurrentDb
' Get Job_ID and Week records for all OPEN Jobs.
' Expect this to possibly be the first date, possibly a gap in dates, then
' one or more weekly dates.
strSQL = "SELECT tblProjects.Job_ID, tblProjects.DateEnded, tblJobWeeks.WorkWeek " & _
"FROM tblProjects INNER JOIN tblJobWeeks ON tblProjects.Job_ID = tblJobWeeks.Job_ID " & _
"WHERE (((tblProjects.DateEnded) Is Null)) " & _
"ORDER BY tblProjects.Job_ID, tblJobWeeks.WorkWeek;"
Set rsJobs = dbs.OpenRecordset(strSQL)
If rsJobs.EOF Then
MsgBox "No Jobs found!", vbOKOnly + vbCritical, "No Jobs"
GoTo Exit_Code
Else
rsJobs.MoveFirst
End If
' First, find prior Monday's date as a baseline
dPriorMonday = DateAdd("ww", -1, Date - (Weekday(Date, vbMonday) - 1))
' Calculate +35 weeks -- and make sure the date will be a monday.
If Weekday(Date, 1) = 2 Then
dEndDate = DateAdd("ww", iWksToAdd, Date)
Else
dEndDate = DateAdd("ww", iWksToAdd, dPriorMonday)
End If
' Open the 'Weekly' table for inserting 35 new records, plus missing dates
strSQL = "select * from tblJobWeeks order by Job_ID, WorkWeek"
Set rsWeek = dbs.OpenRecordset(strSQL)
' FYI: It doesn't make sense to add records between the 'start' date and + 35 weeks, then
' have your monthly process delete empty ones from prior months.
' This code will only add missing records going back 4 weeks.
' Your notes indicated there would be at least two records for any given Job. If that is
' not correct, this code may not work!
' Save the starting point
strJobID = rsJobs!Job_ID
dTempDate = rsJobs!WorkWeek
Do While Not rsJobs.EOF
Debug.Print "Job: " & rsJobs!Job_ID & vbTab & "First Date: " & rsJobs!WorkWeek & vbTab & "W/E: " & rsJobs!WorkWeek
If strJobID <> rsJobs!Job_ID Then ' We have changed to a NEW Job_ID
' Fill the +35 weeks
' Only add prior 4 wks , then +35
If dTempDate < dEndDate Then dTempDate = DateAdd("ww", -3, dPriorMonday) ' Get date from 3 or 4 weeks back.
Do
If dTempDate < dEndDate Then
' Don't add dates over 4 weeks old - Remove this if necessary
If dTempDate >= DateAdd("ww", -4, Date) Then
Debug.Print "Insert ID: " & strJobID & vbTab & dTempDate
Add_Week strJobID, dTempDate
Else
Debug.Print "Skip - Older than 4 weeks: " & vbTab & dTempDate
End If
dTempDate = DateAdd("ww", 1, dTempDate)
Else
Exit Do
End If
Loop
strJobID = rsJobs!Job_ID
dTempDate = DateAdd("ww", 1, rsJobs!WorkWeek) ' Should be the FIRST date for this Job
Else
If rsJobs!WorkWeek = dTempDate Then
dTempDate = DateAdd("ww", 1, dTempDate)
Else
' Don't add dates over 4 weeks old - Remove this if necessary
If dTempDate > DateAdd("ww", -4, Date) Then
Debug.Print "Insert ID: " & strJobID & vbTab & dTempDate
Add_Week strJobID, dTempDate
Else
Debug.Print "Skip - Older than 4 weeks: " & vbTab & dTempDate
End If
dTempDate = DateAdd("ww", 1, dTempDate)
End If
End If
rsJobs.MoveNext
Loop
'Check if last ID has +35 dates
If dTempDate < dEndDate Then
Do Until dEndDate = dTempDate
' Don't add dates over 4 weeks old - Remove this if necessary
If dTempDate > DateAdd("ww", -4, Date) Then
Debug.Print "Insert ID: " & strJobID & vbTab & dTempDate
Add_Week strJobID, dTempDate
Else
Debug.Print "Skip - Older than 4 weeks: " & vbTab & dTempDate
End If
dTempDate = DateAdd("ww", 1, dTempDate)
Loop
End If
Exit_Code:
If Not rsJobs Is Nothing Then
rsJobs.Close
Set rsJobs = Nothing
End If
If Not rsWeek Is Nothing Then
rsWeek.Close
Set rsWeek = Nothing
End If
dbs.Close
Set dbs = Nothing
Exit Function
Error_Trap:
Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Weeks"
' If duplicate record, ignore
If Err.Number = 3022 Then
Resume Next
End If
MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Weeks"
Create_New_Weeks = "Error: " & Err.Number & vbTab & Err.Description & vbCrLf & "In: Create_New_Weeks"
Resume Exit_Code
Resume
End Function
Function Add_Week(strID As String, dDate As Date)
With rsWeek
.AddNew
!Job_ID = strID
!WorkWeek = dDate
!Crew_Num = 0
.Update
End With
End Function
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
I am having problems with an excel macro (VBA) that is meant to grab a date from an excel spreadsheet, subtract one month and reformat it to MMM-YY. Basically I want to take 3/31/2013 and convert it to Feb-13
Here is my code:
Dim ReportDate As Date
ReportDate = Worksheets("Current").Cells(2, 16) 'ex. 03-31-2013
prevMonth = Format((Month(ReportDate) - 1) & "/" & Day(ReportDate) & "/" & Year(ReportDate), "mmm") & "-" & Format(ReportDate, "yy")
Debug.Print prevMonth
The result I get is 2/31/2013-13
So I tried changing the prevMonth variable:
prevMonth = Format((Month(ReportDate) - 1) & "/" & Day(ReportDate) & "/" & Year(ReportDate), "mmm-yy")
But got just 2/31/2013 again
I tried to declare prevMonth as an Integer or a Date but I get a type mismatch error. I can only declare it as a String but it still doesn't help the program.
Thanks in advance for your help.
Try this
Sub Demo()
Dim ReportDate As Date
Dim prevMonth As Date
ReportDate = Worksheets("Current").Cells(2, 16) 'ex. 03-31-2013
prevMonth = DateAdd("m", -1, ReportDate)
Debug.Print Format(prevMonth, "mmm-yy")
End Sub