Ive searched for several hours and since my knowledge of VBA is very limited I'm at a loss. I have an "Inventory Total" for several different items going across the top row (Row B) which is updated by imputing a positive or negative amount on a line below it along with the date of update at the far left (column 1). I have another book that needs to keep track of only the subtractions made to each field by the month.
I already have an (auto_run) macro, so I plan to add this to it. It needs to check today's date and if its the first of the month take the total of all negative numbers (per column) for THAT MONTH ONLY and add it to the top line of the other book.
The part I need to know is how to get the totals per month in VBA.
This is what I'm using to to check today's date:
If Date - Day(Date) + 1 = Date - Day(Date) + 1 And Range("'Monthly Office Inventory'!A2") <> Date - Day(Date) + 1 Then
I'm thinking something like a nested IF check for a value between the first of last month and the end of last month, using the date functions.
Help please?
Sub Datetest()
Dim i As Integer
Dim x As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim crninvbk As Worksheet
Dim mntlisbk As Worksheet
Set crninvbk = Worksheets("Current Office Inventory")
Set mntlisbk = Worksheets("sheet1")
PreviousMonth = DateAdd("m", -1, Date)
Negativemonthly = 0
For x = 2 To 23
For i = 3 To 100
If crninvbk.Cells(i, 1).value >= dhFirstDayInMonth And crninvbk.Cells(i, 1).value <= dhLastDayInMonth Then
If crninvbk.Cells(i, x).value < 0 Then
Negativemonthly = Negativemonthly + crninvbk.Cells(i, x).value
End If
End If
Next i
mntlisbk.Cells(2, x) = Negativemonthly
MsgBox (Negativemonthly)
Negativemonthly = 0
Next x
MsgBox (Negativemonthly)
End Sub
Function dhFirstDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the first day in the specified month.
PreviousMonth = DateAdd("m", -1, Date)
dhFirstDayInMonth = DateSerial(Year(Date), _
Month(PreviousMonth), 1)
End Function
Function dhLastDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
PreviousMonth = DateAdd("m", -1, Date)
dhLastDayInMonth = DateSerial(Year(Date), _
Month(PreviousMonth) + 1, 0)
End Function
Related
I have the current formula created by #ScottCraner which when pasted into Cell Q8 and Dragged down to Q12, populates the cells with the date of each friday this month:
Code:
=IFERROR(AGGREGATE(15,6,ROW(INDEX(A:A,EOMONTH(TODAY(),-1)+1):INDEX(A:A,EOMONTH(TODAY(),0)))/(WEEKDAY(ROW(INDEX(A:A,EOMONTH(TODAY(),-1)+1):INDEX(A:A,EOMONTH(TODAY(),0))),1)=6),ROW(1:1)),"-")
Im trying to convert this into VBA as i understand VBA more than formulas. However was wondering if anyone here could possibly help.
It really is appreciated
This iterates the dates and puts the Fridays in Q8:Q12
Sub myFri()
Dim OArr(1 To 5, 1 To 1) As Variant
Dim k As Long
k = 1
Dim i As Long
For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
If Weekday(i, vbSunday) = 7 Then
OArr(k, 1) = i
k = k + 1
End If
Next i
If k = 5 Then OArr(k, 1) = "-"
Worksheets("Sheet1").Range("Q8:Q12").Value = OArr
Worksheets("Sheet1").Range("Q8:Q12").NumberFormat = "mm/dd/yyyy"
End Sub
Try this quick UDF.
Function listWeekday(dt As Long, ndx As Long, _
Optional wd As Long = 6)
listWeekday = 7 - Weekday(DateSerial(Year(dt), Month(dt), 0), wd) + _
DateSerial(Year(dt), Month(dt), 1) + _
(ndx - 1) * 7
If Month(dt) <> Month(listWeekday) Then _
listWeekday = CVErr(xlErrNA)
End Function
'usage for Fridays in current month
=listWeekday(today(), row(1:1))
'usage for Sundays in current month
=listWeekday(today(), row(1:1), 1)
'usage for Wednesdays in current month
=listWeekday(today(), row(1:1), 4)
I want to calculate some schedules on the basis of given dates. Like I have
Start Date
End Date
Weekdays, for example, Monday, Wednesday as a frequency
and I need to calculate
weekly
biweekly
triweekly
monthly
quarterly
dates from the start and end date and also by matching the given weekdays.
For an example
Date start = 05/07/2018
Date End = 15/07/2018
Frequency days = Saturday
and I need weekly Saturday dates and then biweekly Saturday dates until it reaches to the end date.
I have tried DAYOFWEEK in MS ACCESS VBA which is helping a bit but I need to know the complete solution so I can calculate schedules.
Your help is appreciated.
Thanks
The DateAdd Function can do all that.
Air code:
d = StartDate
Do While d <= EndDate
Debug.Print d ' <-- Output date
Select Case Interval
Case "biweekly": d = DateAdd("ww", 2, d)
Case "monthly" : d = DateAdd("m", 1, d)
' etc.
End Select
Loop
For months, you should always add to the original startdate as this could be one of the last days of a month, thus is would offset the dates for months following a month having fewer days. So:
Dim StartDate As Date
Dim EndDate As Date
Dim NextDate As Date
Dim Interval As Long
StartDate = #1/31/2018#
EndDate = #6/30/2018#
Do
NextDate = DateAdd("m", Interval, StartDate)
Interval = Interval + 1
Debug.Print NextDate
Loop Until NextDate >= EndDate
will return:
2018-01-31
2018-02-28
2018-03-31
2018-04-30
2018-05-31
2018-06-30
For starting on a specific weekday, find the first of this, then add intervals as above:
Public Function DateNextWeekday( _
ByVal datDate As Date, _
Optional ByVal bytWeekday As Byte = vbMonday) _
As Date
' Returns the date of the next weekday, as spelled in vbXxxxday, following datDate.
' 2000-09-06. Cactus Data ApS.
' No special error handling.
On Error Resume Next
DateNextWeekday = DateAdd("d", 7 - (Weekday(datDate, bytWeekday) - 1), datDate)
End Function
This should work too - I have included input boxes so you can enter start date, finish date, day of the week and frequency because I don't know how you want that input; also this will store the values in a Table2 Which has a field/column called Dates and then you can retrieve them (I don't know either how do you want to retrieve the dates, if you want to store them etc.)...I hope this helps!:
Sub test()
'clear the table2:
CurrentDb.Execute "DELETE * FROM Table2"
Dim DBTest As String
Dim RSTest As DAO.Recordset
Dim i As Long
Dim selectorInitDate, selectorEndDate, DBDate As Date
'Enter Start Date
selectorInitDate = Format(InputBox("Initial Date"), "mm/dd/yyyy")
'Enter Finish Date
selectorEndDate = Format(InputBox("End Date"), "mm/dd/yyyy")
'Enter Day of the Week (example: Saturday)
selectorWeekDay = InputBox("Week Day")
'Enter Frecuency (example: weekly, biweekly, etc)
selectorFreqDays = InputBox("Frecuency Days")
If selectorWeekDay = "Sunday" Then WeekDaySelected = 1
If selectorWeekDay = "Monday" Then WeekDaySelected = 2
If selectorWeekDay = "Tuesday" Then WeekDaySelected = 3
If selectorWeekDay = "Wednesday" Then WeekDaySelected = 4
If selectorWeekDay = "Thursday" Then WeekDaySelected = 5
If selectorWeekDay = "Friday" Then WeekDaySelected = 6
If selectorWeekDay = "Saturday" Then WeekDaySelected = 7
If selectorFreqDays = "weekly" Then Freq = 7
If selectorFreqDays = "biweekly" Then Freq = 14
If selectorFreqDays = "triweekly" Then Freq = 21
If selectorFreqDays = "monthly" Then Freq = 30
If selectorFreqDays = "quarterly" Then Freq = 90
DBDate = Format(selectorInitDate, "mm/dd/yyyy")
Count = 0
Do While DBDate <= selectorEndDate
If Weekday(DBDate) = WeekDaySelected Then
DBTest = "INSERT INTO Table2 ([Dates]) " & _
" VALUES (" & _
"'" & DBDate & "');"
CurrentDb.Execute DBTest
DBDate = DBDate + Freq - 1
Count = Count + 1
End If
DBDate = DBDate + 1
Loop
'this retrieves in a msgbox the saturdays found between the two dates you specify:
DBTest = "SELECT * FROM Table2"
Set RSTest = CurrentDb.OpenRecordset(DBTest)
If Not RSTest.BOF And Not RSTest.EOF Then
RSTest.MoveFirst
Do While (Not RSTest.EOF)
If Format(RSTest.Fields("Dates").Value, "mm/dd/yyyy") >= selectorInitDate And _
Format(RSTest.Fields("Dates").Value, "mm/dd/yyyy") <= selectorEndDate Then
mthString = mthString & RSTest.Fields("Dates") & ", "
End If
RSTest.MoveNext
Loop
End If
' (remove last comma)
mthString = Left(mthString, Len(mthString) - 2)
MsgBox Count & " " & selectorWeekDay & "(s) Added" & Chr(43) & mthString
'clear the table2:
CurrentDb.Execute "DELETE * FROM Table2"
End Sub
Following your example this should give you how many saturdays you have between two dates in a weekly basis, and which are those dates.
Note: you need to have selected on your reference the "Microsoft DAO 3.6 Object Library"
If you just wanted the bi-weekly dates grouped in 14 day increments beginning with some starting date (first week of the year for example) indate could be the current date or some date you choose or you could just you today().
Function biweeklyDate(indate as date) as Date
biweeklyDate = (DateSerial(2021,1,4)-indate) Mod 14 + inDate
End function
I am trying to write a script that searches a list of dates, and identifyies how long date gaps are. I'm new to VBA, and this may be completely wrong, but after referencing several sites, here is what I came up with:
Sub IdentifyGaps()
Dim startdate As Date 'first date in column
Dim enddate As Date 'last date in column
Dim ust As Date 'first date of unemployment
Dim i As Long
ust = ActiveCell.Offset(1, 0).Value
With Sheet6
startdate = [A1]
enddate = .Cells(.Rows.Count, "A").End(xlUp).Value
For i = startdate To enddate
If ust <> DateAdd("d", 1, i) Then
Sheet6.[C1].Value = DateDiff("d", i, ust)
End If
Next i
End With
End Sub
I'm not receiving an error, but the macro is not working properly. Right now, it's returning -43074 when it should be returning 15. Any help would be much appreciated!
Here is a screenshot of the data, with the lone date gap it should pick up.
Sub IdentifyGaps()
Dim ws As Worksheet
Dim Date1 As Long, Date2 As Long, Gap As Long, lRow As Long
Set ws = Sheet6
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row
For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
Date1 = ws.Cells(x, 1).Value
Date2 = ws.Cells(x + 1, 1).Value
Gap = DateDiff("d", Date1, Date2)
If Gap > 1 Then
ws.Range("C" & lRow).Value = Gap
lRow = lRow + 1
End If
Next x
Looking at my calendar, I believe your expected result should actually be 17, not 15. This code will return the gap value as a Long value with which you can do whatever you want.
'Reads a column of dates and returns the length of the first gap found
Function IdentifyGaps() As Long
Dim StartDate As Date
Dim EndDate As Date
'This Variable is not needed for this solution, it is instead replaced by Gap
'Dim ust As Date
Dim Gap As Long
'Read cell values into an array for more efficient operation
Dim ReadArray() As Variant
ReadArray = Sheet6.Range("A1").CurrentRegion
Dim LastRow As Long
LastRow = UBound(ReadArray, 1)
StartDate = ReadArray(1, 1)
EndDate = ReadArray(LastRow, 1)
'ThisDate and PreviousDate are declared explicitly to highlight program flow
Dim Row As Long
Dim ThisDate As Date
Dim PreviousDate As Date
For Row = 2 To UBound(ReadArray, 1)
ThisDate = ReadArray(Row, 1)
PreviousDate = ReadArray(Row - 1, 1)
Gap = ThisDate - PreviousDate
If Gap > 1 Then Exit For
Gap = 0
Next Row
IdentifyGaps = Gap
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ProveIt()
Debug.Print IdentifyGaps
End Sub
i am completely new to VBA in Excel and trying to learn as much as I can as fast as I can so it can help me with my master thesis.
I have a fairly large dataset consisting of daily stock returns. I would like to copy the last day of each month into a new sheet but I am stuck in doing so.
Currently I am using a code to generate a column of dates based on column A in a different worksheet. I have provided this code below but it does not actually filter, it just generates the first and 15th day of the next month.
Private Sub Listmonths(strWksResult As String, strWksData As String)
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
FirstDate = Worksheets(strWksData).Range("A21").Value
LastDate = Worksheets(strWksData).Range("A4696").Value
NextDate = FirstDate
Worksheets(strWksResult).Range("A2").Select
'selection of columns within one row
Do Until NextDate >= LastDate
ActiveCell.Value = NextDate
ActiveCell.Offset(1, 0).Select
If Day(NextDate) = 1 Then
NextDate = DateAdd("d", NextDate, 14)
Else
NextDate = DateAdd("d", NextDate, 20)
NextDate = DateSerial(Year(NextDate), Month(NextDate), 1)
End If
Loop
End Sub
Any help would be greatly appreciated!
Thanks in advance
Replace these lines:
If Day(NextDate) = 1 Then
NextDate = DateAdd("d", NextDate, 14)
Else
NextDate = DateAdd("d", NextDate, 20)
NextDate = DateSerial(Year(NextDate), Month(NextDate), 1)
End If
with
Select Case Day(NextDate)
Case 1
NextDate = NextDate + 14
Case 15
NextDate = DateSerial(Year(NextDate), Month(NextDate) + 1, 1) - 1
Case Else
NextDate = DateSerial(Year(NextDate), Month(NextDate) + 1, 1)
End Select
To get (1) the first day of each month, (2) the 15th of each month, and (3) the last day of each month.
If you are merely looking for the last day of each month then you should only use
NextDate = DateSerial(Year(NextDate), Month(NextDate) + 2, 1) - 1
The last day of each month is one day before the first day of the next month. This way it's easy to write either VBA code or an Excel Formula.
If the original date is d, then
DateSerial(Year(d), Month(d) + 1, 1) - 1
is the last day of the month that contains d.
Update
I didn't know which part of the problem is obvious to you. Here is a full version of the code (it found it better to build it from scratch):
Option Explicit
Private Sub Listmonths(strWksResult As String, strWksData As String)
Dim rngResult As Range: Set rngResult = Worksheets(strWksResult).Range("A1")
Dim rngDates As Range: Set rngDates = Worksheets(strWksData).Range("A21:A4696") ' This should be changed to a Named Range or calculation based on UsedRange
Dim rr As Long: rr = 1
Dim r As Long: For r = 1 To rngDates.Rows.Count
Dim varDate As Variant: varDate = rngDates.Cells(r, 1).Value ' In case of performance problems read the whole range at once
If IsDate(varDate) Then
If varDate = DateSerial(Year(varDate), Month(varDate) + 1, 1) - 1 Then
rngResult.Cells(rr, 1).Value = varDate
rngResult.Cells(rr, 2).Value = rngDates.Cells(r, 2).Value ' In case of performance problems write the whole range at once
rr = rr + 1
End If
End If
Next r
End Sub
I managed to use the following formula to calculate the net working days between two dates.The problem is i would like to make it possible for the user to enter what days of the week the person works in another cell and automatically update the formula. Just to make it more user friendly, and prevent the user from messing with the formula. Is there anyway to enter the string(12345) in another cell and have the formula update automatically?
Thanks in advance
Option Explicit
'
' This function tells you how many working days are there between 2 given dates.
' You can use this to calculate working days in countries where saturday and sunday are
' not usually holidays.
'
Function NetWorkingDays(sDateRng As Range, eDateRng As Range, workingDays As String, _
Optional HolidayRng As Range) As Long
'
' e.g. use: =NetWorkingDays($A$1,$A$2,"12356")
' will tell you the count of mondays, tuesdays, wednesdays, fridays and saturdays
' between the dates in $A$1 and $A$2
'
' e.g. use: =NetWorkingDays($A$1,$A$2,"12356",$H$2:$H$50)
' will tell you the count of mondays, tuesdays, wednesdays, fridays and saturdays
' between the dates in $A$1 and $A$2, excluding any holidays (listed as dates) in
' the range $H$2:$H$50
'
' You can also count the number of individual days between dates:
' =NetWorkingDays($A$1,$A$2,"2")
' will tell you the number of tuesdays between those two dates
'
Dim sDate As Date, eDate As Date, Holidays() As Variant
Dim nHolidays As Long
Dim totalDays, startDay As Long, endDay As Long
Dim totWeeks As Long, extraDays As Long
Dim curWeekday As Long
Dim i, retVal As Long
'
If (Not IsDate(sDateRng.Value)) Then
sDate = 0#
Else
sDate = sDateRng.Value
End If
'
If (Not IsDate(eDateRng.Value)) Then
eDate = 0#
Else
eDate = eDateRng.Value
End If
'
If (Not HolidayRng Is Nothing) Then
nHolidays = HolidayRng.Cells.Count
ReDim Holidays(0 To nHolidays - 1)
Holidays = HolidayRng.Value2 ' CAREFUL - this automatically assumes dates in the range!
Else
nHolidays = 0
End If
'
totalDays = eDate - sDate + 1
startDay = Weekday(sDate, vbMonday)
endDay = Weekday(eDate, vbMonday)
'
' First calculate the number of whole weeks in the date span.
' Whole weeks are defined as all weeks that start on Monday and
' end on Sunday.
'
If (startDay = 1) Then
If (endDay = 7) Then
extraDays = 0
Else
extraDays = 7 - endDay
End If
Else
If (endDay = 7) Then
extraDays = 7 - startDay + 1
Else
extraDays = 7 - startDay + 1 + endDay
End If
End If
totWeeks = (totalDays - extraDays) / 7
'
' Now determine how many "extra" days are on either side of
' the whole weeks. Include only those "extra" days that are
' a part of the "workingDays" string.
'
extraDays = 0
If (startDay <> 1) Then
For i = startDay To 7
If (InStr(workingDays, CStr(i)) > 0) Then
extraDays = extraDays + 1
End If
Next i
End If
If (endDay <> 7) Then
For i = 1 To endDay
If (InStr(workingDays, CStr(i)) > 0) Then
extraDays = extraDays + 1
End If
Next i
End If
'
retVal = totWeeks * Len(workingDays) + extraDays
'
' Now subtract out the holidays if applicable to the period in question
'
If (nHolidays > 0) Then
For i = LBound(Holidays) To UBound(Holidays)
If (InStr(workingDays, Weekday(Holidays(i, 1), vbMonday)) > 0 And _
Holidays(i, 1) >= sDate And Holidays(i, 1) <= eDate) Then
retVal = retVal - 1
'Debug.Print Format(Holidays(i, 1), "dd mmm, yyyy") & " was removed: it is a " & Format(Holidays(i, 1), "dddd")
Else
'Debug.Print Format(Holidays(i, 1), "dd mmm, yyyy") & " was not removed: it is a " & Format(Holidays(i, 1), "dddd")
End If
Next i
End If
'
NetWorkingDays = retVal
End Function