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)
Related
Column B is my data - if there is a date value in column B please return week ending date in column C. Need a VBA code to accomplish this
Column B Column C
11/9/2016 11/11/2016
11/8/2016 11/11/2016
4/4/2017 4/7/2017
(blank) (blank)
3/28/2017 3/31/2017
Below is all I could get, but it's not any good.
Dim FirstDayInWeek, LastDayInWeek As Variant
Dim dtmDate As Date
dtmDate = Range("B2:B")
LastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
MsgBox LastDayInWeek
I replied to your comment on how to find the start date of week from a given date?, but here it is as an answer:
Function ReturnDate(DateRange As Date, Optional DayInWeek = 1) As Date
ReturnDate = DateRange - Weekday(DateRange, vbUseSystem) + DayInWeek
End Function
=ReturnDate(A1) gives Monday
=ReturnDate(A1,2) gives Tuesday
.
=ReturnDate(A1,5) gives Friday < --- This is the one you're after.
=ReturnDate(A1,7) gives Sunday.
A blank cell will give 01/01/1900, but you could add a check for that or format the cell not to show 0.
Perhapse you could take an approach like the one below
Sub ReturnWeekEndDate()
Dim InpRng As Range
Dim i As Long
Set InpRng = ActiveSheet.Range("A2:B5")
For i = 1 To InpRng.Rows.Count
If IsDate(InpRng.Cells(i, 1).Value) And IsDate(InpRng.Cells(i, 2).Value) Then
InpRng.Cells(i, 1).Offset(0, 2) = InpRng.Cells(i, 1).Value - Weekday(InpRng.Cells(i, 1).Value, vbUseSystem) + 7
End If
Next i
End Sub
Give this a try:
Sub INeedADate()
Dim i As Long, N As Long, r As Range, Bigr As Range
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
Set r = Cells(i, "B")
If IsDate(r.Value) Then
addy = r.Address
r.Offset(0, 1).Value = Evaluate(addy & "-WEEKDAY(" & addy & ",3)+IF(WEEKDAY(" & addy & ",3)>4,11,4)")
End If
Next i
End Sub
This is similar to using the worksheet formula:
=B1-WEEKDAY(B1,3)+IF(WEEKDAY(B1,3)>4,11,4)
Or try this...
Sub GetFridayDate()
Dim LastDayInWeek As Date
Dim Rng As Range, Cell As Range
Dim lr As Long
lr = Cells(Rows.Count, 2).End(xlUp).Row
Set Rng = Range("B2:B" & lr)
For Each Cell In Rng
If IsDate(Cell.Value) Then
LastDayInWeek = Cell + 8 - Weekday(Cell, vbFriday)
Cell.Offset(0, 1) = LastDayInWeek
End If
Next Cell
End Sub
You said that this would be part of a process...so, just call the function as I have shown, and you're golden! BOOM!
Sub FindEndOfWeek_Test()
Call FindEndOfWeek(ActiveSheet, 1, 2, 6, 1)
End Sub
Function FindEndOfWeek(Sht As Worksheet, KnownDate_Column As Integer, _
EndOfWeek_Column, EndOfWeek As Integer, _
StartingRow As Long)
' This function takes in a spreadsheet, and and determines the date at the end
' of the week, based on known parameters being passed into the function.
'
Dim a As Long
Dim LastRow As Long
Dim EvalDate As Date
Dim NewDate As Date
' Determine the last row of the column you are working with
LastRow = Sht.Cells(Sht.Rows.Count, KnownDate_Column).End(xlUp).Row
' Loop through your entire spreadsheet to determine the end of the week for all rows
For a = StartingRow To LastRow
If IsDate(Sht.Cells(a, KnownDate_Column).Value) = True Then
NewDate = Sht.Cells(a, KnownDate_Column).Value
EvalDay = Weekday(NewDate)
' Determine the known date day of the week, and add accordingly.
If EvalDay < EndOfWeek Then
Sht.Cells(a, EndOfWeek_Column).Value = NewDate + (EndOfWeek - EvalDay)
ElseIf EvalDay > EndOfWeek Then
Sht.Cells(a, EndOfWeek_Column).Value = NewDate + (7 - EvalDay + EndOfWeek)
Else
Sht.Cells(a, EndOfWeek_Column).Value = NewDate
End If
End If
Next a
End Function
I think no need for vba, you use below formula:
=IF(B2<>"",B2+(7-WEEKDAY(B2,16)),"")
If you really need VBA code for this problem, which I did, you can convert the excel formula into a one-line solution like so:
WeekendingDate = Date + 7 - WorksheetFunction.Weekday(Date + 7 - 6)
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
I'm fairly new at VBA. Using Excel 2007 VBA, I'm trying to count the number of entries in the "H" column of the "WOMade" worksheet that have a date in a specific month and year (ignoring the day), but all the methods I've tried aren't working.
Among other ideas, I've tried:
WorksheetFunction.CountIf(Sheets("WOMade").Columns("H:H"), "June-15")
And
WorksheetFunction.CountIf(Format(Sheets("WOMade").Columns("H:H"), "mmyyyy"), "062015")
And
WorksheetFunction.CountIf(Sheets("WOMade").Columns("H:H"), "June/" & "/2015)
And
WorksheetFunction.CountIfs(Sheets("WOMade").Columns("H:H"), ">=" 6/1/2015, Sheets("WOMade").Columns("H:H"), < 7/1/2015)
Any ideas?
I would think that the last example was the closest.
dim i as long
with Sheets("WOMade")
i = WorksheetFunction.CountIfs(.Columns("H:H"), ">=" & dateserial(2015, 6, 1), .Columns("H:H"), "<" & dateserial(2015, 7, 1))
'or,
i = WorksheetFunction.CountIfs(.Columns("H:H"), ">=" & datevalue("6/1/2015"), .Columns("H:H"), "<" & datevalue("7/1/2015"))
'or,
i = WorksheetFunction.CountIfs(.Columns("H:H"), ">=6/1/2015", .Columns("H:H"), "<7/1/2015")
end with
Sub Test()
Sheets("WOMade").Select
SetYear = 2015
SetMonth = 1
Count = 0
i = 1
Do While Cells(i, 8) <> ""
' Subtract for TRUE as it is stored as -1
Count = Count - (Year(Cells(i, 8)) = SetYear And Month(Cells(i, 8)) = SetMonth)
i = i + 1
Loop
MsgBox Count
End Sub
Public Function CountOfYearMonth(r As Range, y As Integer, m As Integer) As Long
Set r = Intersect(r, r.Parent.UsedRange) 'Don't iterate over more than you have to
'Technically n is not necessary, you can just use CountOfYearMonth
Dim n As Long, _
c As Range, _
d As Date
For Each c In r.Cells
If IsDate(c.Value) Then 'Does the cell contain a date?
d = CDate(c.Value) 'Convert, if so
If month(d) = m And year(d) = y Then 'Check year and month
n = n + 1 'If match, increment total
End If
End If
Next c
CountOfYearMonth = n 'Assign return value
End Function
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