I am pulling dates from separate sheets but when using if statement the results are wrong but the dates are correct any help?
Dim tacholine, cal_line As Long
Dim tachodate, calstartdate, calenddate As Date
cal_line = 1
'next calender line
cal_line = cal_line + 1
For tacholine = 1 To 842
'check Week 1
tachodate = Format(Worksheets("All Workers").Range("d" & tacholine), "dd/mm/yyyy")
calstartdate = Format(Worksheets("Calender").Range("b" & cal_line), "dd/mm/yyyy")
calenddate = Format(Worksheets("Calender").Range("c" & cal_line), "dd/mm/yyyy")
If tachodate >= calstartdate And tachodate <= calenddate Then
Application.StatusBar = "Match found : " & tachodate & " between dates " & calstartdate & " and " & calenddate
Worksheets("All Workers").Range("u" & tacholine).Value = Worksheets("Calender").Range("A" & cal_line)
End If
Next tacholine
If you are declaring multiple variables on one line, make sure each variable is specifically declared i.e.
Dim tachodate, calstartdate, calenddate As Date
should be
Dim tachodate As Date, calstartdate As Date, calenddate As Date
In VBA, Dim tachodate, calstartdate, calenddate As Date means only calenddate is declared As Date and tachodate, calstartdate are treated as Variant.
May be try
Dim tacholine, cal_line As Long
'declare all variables separately
Dim tachodate As Date, calstartdate As Date, calenddate As Date
cal_line = 1
'next calender line
'cal_line = cal_line + 1 'moved inside loop
For tacholine = 1 To 842
cal_line = cal_line + 1
'check Week 1
tachodate = Format(Worksheets("All Workers").Range("d" & tacholine), "dd/mm/yyyy")
calstartdate = Format(Worksheets("Calender").Range("b" & cal_line), "dd/mm/yyyy")
calenddate = Format(Worksheets("Calender").Range("c" & cal_line), "dd/mm/yyyy")
If tachodate >= calstartdate And tachodate <= calenddate Then
Application.StatusBar = "Match found : " & tachodate & " between dates " & calstartdate & " and " & calenddate
Worksheets("All Workers").Range("u" & tacholine).Value = Worksheets("Calender").Range("A" & cal_line)
End If
Next tacholine
Related
I have an excel vba sub that sends email reminders every 14 days based on a date in a cell. I would also like to include the week number since the date in the cell to todays date. E.g. Cell date 1st April to present day 28th April to return 4 weeks. Please can someone help.
Sub SalesProgress14()
'
' 14 Day Sales Chase Loop
'
'Dim Answer As VbMsgBoxResult
'Answer = MsgBox("Are you sure you want to run?", vbYesNo, "Run Macro")
'If Answer = vbYes Then
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Dim saledate As String
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = "Sales Chase" & Range("S" & i).Value & " " & Range("U" & i).Value & " " & Range("G" & i).Value
.To = "test#test.com"
.Body = Range("S" & i).Value & " " & Range("U" & i).Value & " " & Range("G" & i).Value
'.display
' Our data below
saledate = Range("F" & i).Value
' Send logic
If DateDiff("d", saledate, Date) Mod 14 = 0 Then .Send
If saledate = Date - 7 Then .Send
End With
Next i
'MsgBox "E-mails successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
' The End If below relates to the run yes or no box
'End If
End Sub
use
DateDiff("w", saledate, Date)
You could use ISOWEEKNUM
Public Sub Test()
Dim saleDate As Date, currDate As Date
saleDate = "2018-04-01"
currDate = "2018-04-28"
Debug.Print Application.WorksheetFunction.IsoWeekNum(currDate) - Application.WorksheetFunction.IsoWeekNum(saleDate)
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 the following code as part of a Job site labor form, which links a full labor call on the "LocLabor" sheet to various single day sign in sheets. This particular code is to add a complete day to the form, and works great, with the exception of these two lines at the bottom:
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
The "scopy", "ecopy", and "brow" variables are used to work out the appropriate lines to copy and paste to the next day. The buttons that are being altered are the newly pasted buttons that were copied within the scopy/ecopy range and are used to add or delete a line from the table they refer to. I need to be able to change the AltText because I am using that as a reference for which day of the labor call they apply to. The "numdays" variable pulls from locsht.Range("L3").Value, which is set to the current number of days on the form prior to running the macro. So it would have a value of 2 when I see the error
Now to the issue - if I have two days existing in the document and I execute the below code, the name of the button changes, but the Alternative Text does not (it remains as "2" or whatever it was prior to copying). Days 4 and up work perfectly though, it is just the transition from day 2 to 3 that I cannot get to work! It also works if I switch out "dayint + 1" to a string, like "banana" for example, but that obviously doesn't help me.
Any ideas would be appreciated.
Option Explicit
Sub add_day()
Dim numdays As String
Dim tbl As TableStyle
Dim newsht As Worksheet
Dim locsht As Worksheet
Dim scopy As Integer
Dim ecopy As Integer
Dim brow As Integer
Dim dayint As Integer
Dim bnum As Integer
Dim tblstart As String
Application.ScreenUpdating = False
'unlock sheet
Worksheets("LocLabor").Unprotect Password:=SuperSecretPW
'set/get variables
Set locsht = Worksheets("LocLabor")
numdays = locsht.Range("L3").Value
dayint = numdays
Worksheets("Labor Sign In Day " & numdays).Copy Before:=Sheets(numdays + 4)
Worksheets("Labor Sign In Day " & numdays & " (2)").Name = "Labor Sign In Day " & numdays + 1
'update number of days on sheet
locsht.Range("L3") = locsht.Range("L3").Value + 1
'rename new sign in sheet
Set newsht = Worksheets("Labor Sign In Day " & numdays + 1)
newsht.Unprotect Password:=SuperSecretPW
'figure out which rows to copy on main sheet
scopy = locsht.ListObjects(dayint).Range.Rows(1).Row - 1
brow = locsht.ListObjects(dayint).Range.Rows.Count
ecopy = scopy + brow
'Copy/paste new day on LocLabor
locsht.Activate
locsht.Rows(scopy & ":" & ecopy).Copy
locsht.Rows(ecopy + 2).Insert Shift:=xlDown
locsht.ListObjects("Tableday" & numdays).Resize Range("A" & scopy + 1 & ":" & "H" & ecopy)
locsht.Range("A" & ecopy + 2 & ":" & "H" & ecopy + 2) = "=IFERROR($A$17+" & numdays & "," & """Enter Load in Date at Top"")"
locsht.Rows(ecopy + 1).EntireRow.Delete
locsht.PageSetup.PrintArea = "$A$1:$H$" & ecopy + (ecopy - scopy + 1)
locsht.HPageBreaks.Add Before:=locsht.Rows(ecopy + 1)
locsht.ListObjects(dayint + 1).Name = "Tableday" & numdays + 1
bnum = (dayint * 2) + 3
tblstart = locsht.ListObjects(dayint + 1).Range.Rows(1).Row + 1
'Enter correct formulas into sign in sheet
With newsht
.ListObjects(1).Name = "signinday" & numdays + 1
.Range("i12") = Left(newsht.Range("i12").Formula, 28) & numdays & Right(newsht.Range("i12").Formula, 48)
.Range("A17") = "=IF(ISBLANK(LocLabor!G" & tblstart & ")=FALSE,LocLabor!G" & tblstart & "&"" ""&LocLabor!F" _
& tblstart & ",IF(ISBLANK(LocLabor!D" & tblstart & ")=TRUE," & """""" & ",LocLabor!D" & tblstart & "))"
.Range("B17") = "=IF(ISBLANK(LocLabor!B" & tblstart & ")=TRUE, """", LocLabor!B" & tblstart & ")"
.Range("G17") = "=IF(ISBLANK(LocLabor!C" & tblstart & ")=TRUE, """", LocLabor!C" & tblstart & ")"
End With
'rename pasted buttons, update alttext
With locsht
.Buttons(bnum).Name = "Button " & bnum
.Buttons(bnum + 1).Name = "Button " & bnum + 1
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
End With
'lock down sheets
Worksheets("LocLabor").Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("LocLabor").EnableSelection = xlUnlockedCells
Worksheets("Labor Sign In Day " & numdays + 1).Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("Labor Sign In Day " & numdays + 1).EnableSelection = xlUnlockedCells
ActiveSheet.Buttons(Application.Caller).TopLeftCell.Offset(3, 0).Select
Application.ScreenUpdating = True
End Sub
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
Can someone please help me to fix the formula in the sub. I need to enter dates into it via variables but it always gives me an error '13' data types
I'm talking about the bit:
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;" >= " & weekstart & "";Rawdata!A2:A3446;" <= " & weekend & "")"
The Sub apart from that formula works.....
Sub get_cal_weeks()
Dim weeks As Integer, i As Integer, col As String, weekstart As Date, weekend As Date, calweeks() As Variant
'start column is D
col = "D"
'get amount of weeks
weeks = countcalweeks()
'populate array calweeks
calweeks = fillcalweeks(weeks)
For i = 0 To weeks
field = i + i + 4
weekstart = calweeks(i, 0)
weekend = calweeks(i, 1)
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;" >= " & weekstart & "";Rawdata!A2:A3446;" <= " & weekend & "")"
Next
End Sub
Thank you
I suggest you convert to long (or double if you need times)
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;"">=" & CLng(weekstart) & """;Rawdata!A2:A3446;""<=" & CLng(weekend) & """)"