How to determine the workday prior to ReceivedTime? - vba

The following code saves Outlook attachments and adds the date that the email was generated to the end of the name.
I am trying to add the previous workday.
Public Sub K_P3(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "W:XXXX\"
Dim dateformat As String
dateformat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & _
Left(objAtt.FileName, InStrRev(objAtt.FileName, ".") - 1) & _
" " & dateformat & _
Mid(objAtt.FileName, InStrRev(objAtt.FileName, "."))
Next
End Sub

Try this:
dateformat = Format(application.workday(itm.ReceivedTime),-1), "yyyy-mm-dd") & _
Format(itm.ReceivedTime, " Hmm")
EDIT: forgot you were using Outlook:
dateformat = Format(Workday(itm.ReceivedTime,1), "yyyy-mm-dd Hmm")
Some code to (I think) mimic Excel's workday function:
Sub Tester()
Dim arrHolidays
arrHolidays = Array(#12/25/2019#) 'array of holidays
Debug.Print Workday(#12/26/2019#, -1) '12/25/2019
Debug.Print Workday(#12/26/2019#, -1, arrHolidays) '12/24/2019
End Sub
'Find the workday `days` ago or in the future starting from `dt`.
'Ignores weekends, and optionally also an array of dates passed to `arrHols`
Function Workday(dt As Date, ByVal days, Optional arrHols As Variant = Empty)
Dim rv, i, dy, delta, hol As Boolean
rv = dt
i = 0
delta = IIf(days < 0, -1, 1) 'what direction are we headed?
Do While i <> days
rv = rv + delta
dy = Weekday(rv, vbMonday) 'Monday=1
If dy <> 6 And dy <> 7 Then 'not a weekend?
'Int() below removes any time component from the date
If Not IsEmpty(arrHols) Then hol = InArray(Int(rv), arrHols)
If Not hol Then i = i + delta 'not a holiday?
End If
Loop
Workday = rv
End Function
'Is value `v` in the array `arr` ?
Function InArray(ByVal v, arr) As Boolean
Dim i As Long
If IsEmpty(arr) Then Exit Function
For i = LBound(arr) To UBound(arr)
If arr(i) = v Then
InArray = True
Exit Function
End If
Next i
End Function

Related

i want to create a VBA code in Word that will create multiple word files with different file names

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

VBA returning incorrect month dates word

I have an issue with the following code for some reason when creating the files it only goes the 30th not the 31st on the correct months and in February it creates up to the 30th. The code is designed to create folder for each month then create a months worth of files from 1 master document. The original code I used worked but did not create the folders.
This is the code returning the error
Sub Folder()
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:\user\test briefing sheet\2019\" ' path to create folders at"
myYear = 19
Dim monthsArray() As Variant
monthsArray = Array("Jan", "Feb", "Mar", "April", "May", "Jun", "Jul", "Aug", "Sept", "Oct", "Nov", "Dec")
Dim currentMonth As Long
For currentMonth = LBound(monthsArray) To UBound(monthsArray)
Dim folderName As String
folderName = 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
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
This was the original code
Sub Mine()
Dim DateStr, FileStr As String
DateStr = Format$(Date, "DD")
FileStr = DateStr & ".docx"
ActiveDocument.Save
ChangeFileOpenDirectory "c:\user\test briefing sheet\2019\"
ActiveDocument.SaveAs2 FileName:=FileStr, FileFormat:=wdFormatXMLDocument
End Sub
Any ideas?
In this line:
ActiveDocument.SaveAs2 FileName:=folderName & Application.PathSeparator & monthsArray(currentMonth) & " " & currentDay, FileFormat:=wdFormatXMLDocument
currentDay is Long, while you are trying to use it as string. I'd code it as follows:
Dim documentName as string
documentName = monthsArray(currentMonth) & " " & CStr(currentDay)
ActiveDocument.SaveAs2 FileName:=folderName & Application.PathSeparator & documentName, FileFormat:=wdFormatXMLDocument
Also, I'd re-write this line:
endOfMonth = CLng(Format$(dhLastDayInMonth(DateSerial(myYear, currentMonth + 1, 0)), "dd"))
as:
endOfMonth = DAY(dhLastDayInMonth(DateSerial(myYear, currentMonth + 1, 0)))

MS ACCESS VBA, working days function incl. holiday when faling on weekend

When deploying MSDN function for calculating working days, beside a problem with date formatting I found an issue with Holiday count.
Calculation is correct, but only if Holiday is on working day. If it is on a saturday or sunday, it also substract it and produce a false result.
illustration of a false reading
A Function for Workdays:
Public Function Workdays(ByRef startDate As Date, ByRef endDate As Date, Optional ByRef strHolidays As String = "Holidays") As Integer
On Error GoTo Workdays_Error
Dim nWeekdays, nHolidays As Integer
Dim strWhere As String
startDate = DateValue(startDate)
endDate = DateValue(endDate)
nWeekdays = Weekdays(startDate, endDate)
If nWeekdays = -1 Then
Workdays = -1
GoTo Workdays_Exit
End If
strWhere = "[Holiday] >= #" & Format(startDate, "yyyy\/mm\/dd") & "# AND [Holiday] <= #" & Format(endDate, "yyyy\/mm\/dd") & "#"
nHolidays = DCount(Expr:="[Holiday]", Domain:=strHolidays, Criteria:=strWhere)
Workdays = nWeekdays - nHolidays
Workdays_Exit:
Exit Function
Resume Workdays_Exit
End Function
And here is a function for calculating weekdays:
Public Function Weekdays(ByRef startDate As Date, ByRef endDate As Date) As Integer
' Returns the number of weekdays in the period from startDate
' to endDate inclusive. Returns -1 if an error occurs.
On Error GoTo Weekdays_Error
Const ncNumberOfWeekendDays As Integer = 2 'The number of weekend days per week.
Dim varDays As Variant 'The number of days inclusive.
Dim varWeekendDays As Variant 'The number of weekend days.
Dim dtmX As Date 'Temporary storage for datetime.
' If the end date is earlier, swap the dates.
If endDate < startDate Then
dtmX = startDate
startDate = endDate
endDate = dtmX
End If
' Calculate the number of days inclusive (+ 1 is to add back startDate).
varDays = DateDiff(Interval:="d", date1:=startDate, date2:=endDate) + 1
' Calculate the number of weekend days.
varWeekendDays = (DateDiff(Interval:="ww", date1:=startDate, date2:=endDate) _
* ncNumberOfWeekendDays) + IIf(DatePart(Interval:="w", _
Date:=startDate) = vbSunday, 1, 0) + IIf(DatePart(Interval:="w", Date:=endDate) = vbSaturday, 1, 0)
' Calculate the number of weekdays.
Weekdays = (varDays - varWeekendDays)
Weekdays_Exit:
Exit Function
Weekdays_Error:
Weekdays = -1
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Weekdays"
Resume Weekdays_Exit
Please advise how to ignore holiday if holiday = 1 or holiday = 7.
Plus, in extended period of time, there could be more than one holidays, falling or not on weekend.
It is much simpler just to loop the dates and count:
Public Function DateDiffWorkdays( _
ByVal datDate1 As Date, _
ByVal datDate2 As Date, _
Optional ByVal booWorkOnHolidays As Boolean) _
As Long
' Calculates the count of workdays between datDate1 and datDate2.
' 2014-10-03. Cactus Data ApS, CPH
Dim aHolidays() As Date
Dim lngDiff As Long
Dim lngSign As Long
Dim lngHoliday As Long
lngSign = Sgn(DateDiff("d", datDate1, datDate2))
If lngSign <> 0 Then
If booWorkOnHolidays = True Then
' Holidays are workdays.
Else
' Retrieve array with holidays between datDate1 and datDate2.
aHolidays = GetHolidays(datDate1, datDate2)
End If
Do Until DateDiff("d", datDate1, datDate2) = 0
Select Case Weekday(datDate1)
Case vbSaturday, vbSunday
' Skip weekend.
Case Else
' Check for holidays to skip.
' Ignore error when using LBound and UBound on an unassigned array.
On Error Resume Next
For lngHoliday = LBound(aHolidays) To UBound(aHolidays)
If Err.Number > 0 Then
' No holidays between datDate1 and datDate2.
ElseIf DateDiff("d", datDate1, aHolidays(lngHoliday)) = 0 Then
' This datDate1 hits a holiday.
' Subtract one day before adding one after the loop.
lngDiff = lngDiff - lngSign
Exit For
End If
Next
On Error GoTo 0
lngDiff = lngDiff + lngSign
End Select
datDate1 = DateAdd("d", lngSign, datDate1)
Loop
End If
DateDiffWorkdays = lngDiff
End Function
and the holidays function:
Public Function GetHolidays( _
ByVal datDate1 As Date, _
ByVal datDate2 As Date, _
Optional ByVal booDesc As Boolean) _
As Date()
' Finds the count of holidays between datDate1 and datDate2.
' The holidays are returned as an array of dates.
' DAO objects are declared static to speed up repeated calls with identical date parameters.
' 2014-10-03. Cactus Data ApS, CPH
' The table that holds the holidays.
Const cstrTable As String = "tblHoliday"
' The field of the table that holds the dates of the holidays.
Const cstrField As String = "HolidayDate"
' Constants for the arrays.
Const clngDimRecordCount As Long = 2
Const clngDimFieldOne As Long = 0
Static dbs As DAO.Database
Static rst As DAO.Recordset
Static datDate1Last As Date
Static datDate2Last As Date
Dim adatDays() As Date
Dim avarDays As Variant
Dim strSQL As String
Dim strDate1 As String
Dim strDate2 As String
Dim strOrder As String
Dim lngDays As Long
If DateDiff("d", datDate1, datDate1Last) <> 0 Or DateDiff("d", datDate2, datDate2Last) <> 0 Then
' datDate1 or datDate2 has changed since the last call.
strDate1 = Format(datDate1, "\#yyyy\/mm\/dd\#")
strDate2 = Format(datDate2, "\#yyyy\/mm\/dd\#")
strOrder = Format(booDesc, "\A\s\c;\D\e\s\c")
strSQL = "Select " & cstrField & " From " & cstrTable & " " & _
"Where " & cstrField & " Between " & strDate1 & " And " & strDate2 & " " & _
"Order By 1 " & strOrder
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
' Save the current set of date parameters.
datDate1Last = datDate1
datDate2Last = datDate2
End If
lngDays = rst.RecordCount
If lngDays = 0 Then
' Leave adatDays() as an unassigned array.
Else
ReDim adatDays(lngDays - 1)
' As repeated calls may happen, do a movefirst.
rst.MoveFirst
avarDays = rst.GetRows(lngDays)
' rst is now positioned at the last record.
For lngDays = LBound(avarDays, clngDimRecordCount) To UBound(avarDays, clngDimRecordCount)
adatDays(lngDays) = avarDays(clngDimFieldOne, lngDays)
Next
End If
' DAO objects are static.
' Set rst = Nothing
' Set dbs = Nothing
GetHolidays = adatDays()
End Function
without delving into your code, I'd suggest doing a count of holidays in your holiday table that fall on weekends and which also fall inside the range of days you are considering. Subtract that total from an (I presume) otherwise correctly calculated total and you should have the proper adjustment taking weekend holidays into account.
You can use the function below to get the number of working days (excluding public holidays) between two dates.
It requires a table named tbHolidays with a single field named _Date which holds the public holidays.
Public Function WorkingDaysInDateRange(ByVal DateFrom As Date, _
ByVal DateTo As Date, _
Optional ByVal includeStartDate As Long = 0) As Long
On Error GoTo ErrorTrap
'Calculate the number of days
Dim lngTotalDays As Long
lngTotalDays = DateDiff("y", DateFrom, DateTo) + includeStartDate
'Calculate the number of weekend days.
Dim lngWeekendDays As Long
lngWeekendDays = (DateDiff("ww", DateFrom, DateTo) * 2) + _
IIf(DatePart("w", DateFrom) = vbSunday, 1, 0) + _
IIf(DatePart("w", DateTo) = vbSaturday, 1, 0)
'Get Non working days count from tbHolidays excluding weekends
Dim lngHolidays As Long
lngHolidays = DCount("[_Date]", "tbHolidays", _
StringFormat("[_Date] Between #{0}# AND #{1}# AND Weekday([_Date]) Not In ({2}, {3})", Format(DateFrom, "mm/dd/yyyy"), _
Format(DateTo, "mm/dd/yyyy"), _
vbSaturday, vbSunday))
Dim lngWrkDays As Long
lngWrkDays = lngTotalDays - (lngWeekendDays + lngHolidays)
'Return
WorkingDaysInDateRange = lngWrkDays
Leave:
On Error GoTo 0
Exit Function
ErrorTrap:
MsgBox Err.Description, vbCritical
Resume Leave
End Function
The helper StringFormat function:
Public Function StringFormat(ByVal Item As String, ParamArray args() As Variant) As String
Dim idx As Long
For idx = LBound(args) To UBound(args)
Item = Replace(Item, "{" & idx & "}", args(idx))
Next idx
StringFormat = Item
End Function

Excel Macro -- return list of items meeting conditions

I have a pretty simple excel macro that checks a range of cells for the presence of each value in a reference range of cells. If a value from the reference range is not found then it displays a message that the value was not found. The user then has to click okay for the check to continue to the next item. I would like to modify the macro to check all values and only return a list of those not found after all checks are complete. Suggestions?
Current code:
Sub ChkAfternoonAssignmentsV2()
Dim dayToChk As Variant
Dim i As Variant
Dim r As Range
Dim p As Variant
ReEnter:
dayToChk = InputBox("Which day (use 3-letter abbreviation) would you like to check afternoon assignments?")
If dayToChk = "Mon" Then
Set r = ActiveSheet.Range("MonAft_MA_Slots")
ElseIf dayToChk = "Tue" Then
Set r = ActiveSheet.Range("TueAft_MA_Slots")
ElseIf dayToChk = "Wed" Then
Set r = ActiveSheet.Range("WedAft_MA_Slots")
ElseIf dayToChk = "Thu" Then
Set r = ActiveSheet.Range("ThuAft_MA_Slots")
ElseIf dayToChk = "Fri" Then
Set r = ActiveSheet.Range("FriAft_MA_Slots")
Else
MsgBox dayToChk & " is not in the expected format. Try Mon, Tue, Wed, Thu, or Fri."
GoTo ReEnter
End If
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Checking MA Assignments", _
AckTime, "Checking MA Assignments", 0)
Case 1, -1
End Select
For Each i In Sheets("Control").Range("MA_List")
If WorksheetFunction.CountIf(r, i) < 1 Then
If i <> "OOO" Then
MsgBox i & " is not assigned"
End If
ElseIf WorksheetFunction.CountIf(r, i) > 1 Then
If i <> "OOO" Then
MsgBox i & " is assigned more than once. Did you really mean to do that?"
End If
End If
Next i
you could try this
Option Explicit
Sub ChkAfternoonAssignmentsV2()
Dim dayToChk As Variant
Dim i As Variant
Dim r As Range
Dim p As Variant
Do While r Is Nothing
dayToChk = InputBox("Which day (use 3-letter abbreviation) would you like to check afternoon assignments?")
Select Case dayToChk
Case "Mon", "Tue", "Wed", "Thu", "Fri"
Set r = ActiveSheet.Range(dayToChk & "Aft_MA_Slots")
Case Else
MsgBox "'dayToChk & " ' is not in the expected format. Try Mon, Tue, Wed, Thu, or Fri."
End Select
Loop
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Checking MA Assignments", AckTime, "Checking MA Assignments", 0)
Case 1, -1
End Select
Dim notFounds As String, duplicates As String
For Each i In Sheets("Control").Range("MA_List")
If WorksheetFunction.CountIf(r, i) < 1 Then
If i <> "OOO" Then notFounds = notFounds & i.Value & vbLf
ElseIf WorksheetFunction.CountIf(r, i) > 1 Then
If i <> "OOO" Then duplicates = duplicates & i.Value & vbLf
End If
Next i
If notFounds <> "" Then MsgBox "these items have not been found: " & vbCrLf & vbCrLf & notFounds
If duplicates <> "" Then MsgBox "these items have duplicates: " & vbCrLf & vbCrLf & duplicates
End Sub
Compiled but not tested:
Sub ChkAfternoonAssignmentsV2()
Dim dayToChk As Variant
Dim i As Variant
Dim r As Range
Dim p As Variant
Dim days, m, sMsg As String, n
days = Array("Mon", "Tue", "Wed", "Thu", "Fri")
Do
dayToChk = InputBox("Which day (Mon, Tue, Wed, Thu, Fri) " & _
"would you like to check afternoon assignments?")
If Len(dayToChk) = 0 Then Exit Sub 'exit if nothing entered
If IsError(Application.Match(dayToChk, days, 0)) Then
MsgBox dayToChk & " is not in the expected format.", vbExclamation
Else
Set r = ActiveSheet.Range(dayToChk & "Aft_MA_Slots")
End If
Loop While r Is Nothing
'skipping the wscript messagebox code...
For Each i In Sheets("Control").Range("MA_List")
If i <> "OOO" Then
n = WorksheetFunction.CountIf(r, i)
If n < 1 Then
sMsg = sMsg & vbLf & i & " is not assigned"
ElseIf n > 1 Then
sMsg = sMsg & vbLf & i & " is assigned more than once." & _
" Did you really mean to do that?"
End If
End If
Next i
If sMsg <> "" Then
MsgBox "Some issues were found:" & sMsg, vbExclamation
End If
End Sub

VBA: Printer list

I want to develop a print system for check a daily list of documents to print and do it every hour.
Until now I could print one document but when the time has come to print more the code only works for the first.
Sub printTag()
Dim strCommand As String
Dim filePath As String
Dim FileName As String
Dim printer As String
Dim numRefs As Integer
Dim x As Integer
Dim ref As String
Dim numFiles As Integer
Dim t As Integer
Dim difD As Long
Dim difH As Long
Dim difM As Long
Dim listDate As Date
Dim nowDate As Date
nowDate = ThisWorkbook.Sheets("Print").Range("B8")
printer = ThisWorkbook.Sheets("Print").Range("B2")
numRefs = WorksheetFunction.CountA(ThisWorkbook.Sheets("List").Columns("A"))
numFiles = WorksheetFunction.CountA(ThisWorkbook.Sheets("Relation").Columns("A"))
For x = 1 To numRefs
On Error Resume Next
listDate = ThisWorkbook.Sheets("List").Range("A" & x)
difD = DateDiff("d", nowDate, listDate)
If difD = 0 Then
difH = DateDiff("h", nowDate, listDate)
difM = DateDiff("n", nowDate, listDate)
If difH = 0 Then
If difM >= 0 Then
For t = 1 To numFiles
If ThisWorkbook.Sheets("List").Range("B" & x) = ThisWorkbook.Sheets("Relation").Range("A" & t) Then
filePath = ThisWorkbook.Sheets("Print").Range("B1") & "\" & ThisWorkbook.Sheets("Relation").Range("B" & t)
ThisWorkbook.Sheets("Print").Range("B3") = strCommand
strCommand = "PRINT " & filePath & "/D:" & printer
Shell strCommand, 1
End If
Next t
End If
End If
End If
Next x
End Sub
I'd got the idea to create a script instead send multiples instances in command line and works perfectly. This is the result:
Sub printTag()
Dim strCommand As String
Dim filePath As String
Dim FileName As String
Dim printer As String
Dim numRefs As Integer
Dim x As Integer
Dim ref As String
Dim numFiles As Integer
Dim t As Integer
Dim difD As Long
Dim difH As Long
Dim difM As Long
Dim listDate As Date
Dim nowDate As Date
nowDate = ThisWorkbook.Sheets("Print").Range("B8")
printer = ThisWorkbook.Sheets("Print").Range("B2")
numRefs = WorksheetFunction.CountA(ThisWorkbook.Sheets("List").Columns("A"))
numFiles = WorksheetFunction.CountA(ThisWorkbook.Sheets("Relation").Columns("A"))
If Len(Dir$(ThisWorkbook.Path & "\list.bat")) > 0 Then
Kill ThisWorkbook.Path & "\list.bat"
End If
intFile = FreeFile()
Open ThisWorkbook.Path & "\list.bat" For Output As #intFile
For x = 1 To numRefs
On Error Resume Next
listDate = ThisWorkbook.Sheets("List").Range("A" & x)
difD = DateDiff("d", nowDate, listDate)
If difD = 0 Then
difH = DateDiff("h", nowDate, listDate)
difM = DateDiff("n", nowDate, listDate)
If difH = 0 Then
If difM >= 0 Then
For t = 1 To numFiles
If ThisWorkbook.Sheets("List").Range("B" & x) = ThisWorkbook.Sheets("Relation").Range("A" & t) Then
filePath = ThisWorkbook.Sheets("Print").Range("B1") & "\" & ThisWorkbook.Sheets("Relation").Range("B" & t)
Print #intFile, "PRINT " & filePath & " /D:" & printer
End If
Next t
End If
End If
End If
Next x
Print #intFile, "exit"
Close #intFile
End Sub