Hi (please excuse the bad formatting and conventions I am not a coder)
I have a VBA function that calculates the time weighted average given a table of dates and values. The problem is that I cannot pass the iterator through one of the excel functions.
The issue arises in the following line:
totalWeighting = totalWeighting + Cells(Application.Match(start_date, dateRange, 1), userCodeColumn)
When using start_date the function works fine (note that I have a bunch of other code to Dim variables which I have excluded). However, when you replace start_date with "d", it returns #value.
Function TimeWeightedAverage(start_date As Date, end_date As Date, user_code) As Double
Dim d As Date
Dim totalWeighting As Double
Dim userCodeColumn As Integer
Dim dateRange As Range
Dim denominator As Integer
Dim startRow As Integer
If Mid(user_code, 3, 1) = 2 Then
Set dateRange = ActiveSheet.Range("A:A")
Else
Set dateRange = ActiveSheet.Range("H:H")
End If
totalWeighting = 0
denominator = WorksheetFunction.NetworkDays(start_date, end_date)
Let userCodeColumn = user_code.Column
Let startRow = Application.Match(start_date, dateRange, 1)
For d = start_date To end_date
If WorksheetFunction.Weekday(d, 11) < 6 Then
totalWeighting = totalWeighting + Cells(Application.Match(d, dateRange, 1), userCodeColumn)
End If
Next
TimeWeightedAverage = totalWeighting / denominator
Any thoughts would be greatly appreciated.
Data:
Ok I think I sorted out your problem.
First of all, a loop like the one you used works with integer/longs/singles/doubles... not dates, so you can't use d as a date, because it is not.
On the other hand you were declarin a startrow which wasn't being used like denominator which was calculating the working days between the 2 dates. Instead, calculate all the days between the 2 dates and loop through all of them increasing 1 day to startdateat a time and giving that day to a Date variable, your Ifstatement will handle if it's a working day or not.
Option Explicit
Function TimeWeightedAverage(start_date As Date, end_date As Date, user_code As Range) As Double
Dim d As Long
Dim userCodeColumn As Long
Dim dateRange As Range
Dim denominator As Long
Dim CheckDate As Date
If Mid(user_code, 3, 1) = 2 Then
Set dateRange = ActiveSheet.Range("A:A")
Else
Set dateRange = ActiveSheet.Range("H:H")
End If
denominator = DateDiff("d", start_date, end_date)
Let userCodeColumn = user_code.Column
For d = 1 To denominator
If d = 1 Then
CheckDate = start_date
Else
CheckDate = start_date + d
End If
If WorksheetFunction.Weekday(CheckDate, 11) < 6 Then
TimeWeightedAverage = TimeWeightedAverage + ActiveSheet.Cells(Application.Match(CheckDate, dateRange, 1), userCodeColumn)
End If
Next
End Function
Related
I am aware that this question has been asked in many different forms, but I would like to show my case as I have not found the perfect solution for it.
So, what I need to do is divide every month in 4 or 5 weeks, and type it into the corresponding cells.
Example :
I have tried this sample code written by User : danieltakeshi in this thread :
https://stackoverflow.com/a/47393516/11969596
But it has a flaw in it, for example if you type a date from October 2021 the result outputs 6 weeks which is impossible :
Sub WeeksInMonth()
Dim MonthYear As String, txt As String
Dim InputDate As Date, MonthYearDay As Date
Dim i As Long, intDaysInMonth As Long, j As Long
Dim MyArray As Variant
Dim arr As New Collection, a
ReDim MyArray(0 To 31)
j = 0
InputDate = ("1 / 10 / 2021") ' Date from October
MonthYear = Month(InputDate) & "/" & Year(InputDate)
intDaysInMonth = Day(DateSerial(Year(MonthYear), Month(MonthYear) + 1, 0))
For i = 1 To intDaysInMonth
MonthYearDay = DateSerial(Year(InputDate), Month(InputDate), i)
MyArray(j) = Application.WorksheetFunction.WeekNum(MonthYearDay)
j = j + 1
Next i
ReDim Preserve MyArray(0 To j - 1)
On Error Resume Next
For Each a In MyArray
arr.Add a, CStr(a)
Next
For i = 1 To arr.Count
Debug.Print arr(i)
Next
End Sub
Please help me find a solution, or tell me how I can adapt it to my current situation.
Cordially,
This routine checks for the first and last workingday (monday to friday) and then gives the calendar weeks for that date range
Option Explicit
Public Sub test_getWeeknumbersForMonth()
Dim arr As Variant
arr = getWeekNumbersForMonth("1.10.2021")
Debug.Print "1.10.2021: ", Join(arr, " - ")
arr = getWeekNumbersForMonth("1.1.2022")
Debug.Print "1.1.2022: ", Join(arr, " - ")
End Sub
Public Function getWeekNumbersForMonth(inputDate As Date) As Variant
Dim datStart As Date
datStart = getFirstWorkingDayOfMonth(inputDate)
Dim datEnd As Date
datEnd = getLastWorkingDayOfMonth(inputDate)
Dim arrWeekNumbers As Variant
ReDim arrWeekNumbers(1 To 6) 'max 6 weeks can be returned
Dim i As Long: i = 1
Dim dat As Date
dat = datStart
While dat <= datEnd
arrWeekNumbers(i) = getCalendarWeek(dat)
i = i + 1
dat = DateAdd("ww", 1, dat)
Wend
ReDim Preserve arrWeekNumbers(i - 1)
getWeekNumbersForMonth = arrWeekNumbers
End Function
Private Function getFirstWorkingDayOfMonth(inputDate As Date) As Date
Dim datToCheck As Date: datToCheck = DateSerial(Year(inputDate), Month(inputDate), 1) - 1
Dim isWorkingday As Boolean
Do
datToCheck = datToCheck + 1
isWorkingday = Weekday(datToCheck, vbMonday) <= 5
Loop Until isWorkingday = True
getFirstWorkingDayOfMonth = datToCheck
End Function
Private Function getLastWorkingDayOfMonth(inputDate As Date) As Date
Dim datToCheck As Date: datToCheck = DateSerial(Year(inputDate), Month(inputDate) + 1, 1)
Dim isWorkingday As Boolean
Do
datToCheck = datToCheck - 1
isWorkingday = Weekday(datToCheck, vbMonday) <= 5
Loop Until isWorkingday = True
getLastWorkingDayOfMonth = datToCheck
End Function
Private Function getCalendarWeek(inputDate As Date) As Long
'european iso week - CW 1 = week with first thursday
getCalendarWeek = Application.WorksheetFunction.IsoWeekNum(inputDate)
'use weeknum-function -adjust second parameter to your needs
'https://support.microsoft.com/en-us/office/weeknum-function-e5c43a03-b4ab-426c-b411-b18c13c75340
'getCalendarWeek = Application.WorksheetFunction.WeekNum(inputDate, 2)
End Function
First, some months have dates in six weeks.
Next, VBA natively can't return the correct ISO 8601 weeknumbers:
How to get correct week number in Access
Finally, week numbers don't care about workdays or weekends. If you wish to exclude weeks that don't include specific weekdays, filter on the dates of these.
this is my first time to write here ,,, um so glad for that ,
now i have excel file i try to put a start date and end date , and type the dates between this dates in range ... while lest say example
i try to use this code
Sub datetest()
Dim x, y, z, v, a, b As Range
Set x = Cells.Range("k2")
Set y = Cells.Range("l2")
Set z = Cells.Range("m2")
Set v = Cells.Range("n2")
Set a = Cells.Range("o2")
Set b = Cells.Range("p2")
Dim startDate As Date
Dim endDate As Date
startDate = DateSerial(x, y, z)
endDate = DateSerial(v, a, b)
Dim i As Integer
i = 1
While startDate <= endDate
Cells(i, 1) = startDate
startDate = startDate + 31
i = i + 1
Wend
End Sub
when i run the code , it type the dates good .
my problem is now i add 31 day ,, and the dates not come out right ,
i need to edit the code to add month per time , not a day like
start date 1-3-2020
end date 1-3-2021
the result come out date format ddd - mmm - yyyy
1-3-2020
1-4-2020
1-5-2020
1-6-2020
1-7-2020
and go on till to get to
1-3-2021
again thanks alot for ur time
Try this:
Sub datetest()
Dim x, y, z, v, a, b As Range
Set x = Cells.Range("k2")
Set y = Cells.Range("l2")
Set z = Cells.Range("m2")
Set v = Cells.Range("n2")
Set a = Cells.Range("o2")
Set b = Cells.Range("p2")
Dim startDate As Date
Dim endDate As Date
startDate = DateSerial(x, y, z)
endDate = DateSerial(v, a, b)
Dim i As Integer
i = 1
While startDate <= endDate
Cells(i, 1) = startDate
startDate = DateSerial(Year(startDate), Month(startDate) + 1, Day(startDate))
i = i + 1
Wend
End Sub
Problem
The following [mcve] will output an array of arrays of week numbers between two dates. It works when both dates are on the same year, however, some years have 52 weeks and start within the last days of the last year. And others have 53 weeks.
An example of 52 weeks is the 2020 calendar:
Where the first week begins on Dec 30.
And the example of 53 weeks is the 2016 calendar:
That begins only on Jan 4th.
Code
The following code is commented and outputs an array of arrays with the week numbers.
Sub w_test()
Dim Arr() As Variant, ArrDateW() As Variant
'Initial Date
DateI = DateSerial(2015, 5, 5)
'Final Date
DateF = DateSerial(2017, 9, 20)
'Difference in weeks between DateI and DateF
weekDif = DateDiff("ww", DateI, DateF) + k - 1
i = Weekday(DateI)
d = DateI
'If not Sunday, go back to last week, to start the loop
If i <> 1 Then
d = DateAdd("d", -(i - 1), d)
End If
ReDim ArrDateW(weekDif)
ReDim Arr(2)
'Loop on all weeks between two dates to populate array of arrays
For i = 0 To weekDif
'Date
Arr(0) = d
'Trying to solve problem with New Year
If Application.WorksheetFunction.WeekNum(d) = 53 Then
flag = True
End If
If flag = False Then
Arr(1) = Application.WorksheetFunction.WeekNum(d)
Else
Arr(1) = Application.WorksheetFunction.WeekNum(DateSerial(Year(d) + 1, 1, 1))
flag = False
End If
'Year
Arr(2) = Year(d)
'Populate array of arrays
ArrDateW(i) = Arr
'Next Week Number
d = DateAdd("ww", 1, d)
Next i
'To stop with Ctrl+F8
Debug.Print d
End Sub
Question
2015 had 53 weeks, however the program outputs the following:
And between 2016 and 2017, the output is a mess:
How to fix the program to output these week numbers correctly?
I went about it somewhat differently, relying on built-in VBA functions to correctly calculate the week numbers. Read about ISO week numbers is this answer and see how I'm using the DataPart function -- though you can substitute your own version of Ron de Bruin's ISO week number function if you feel it's warranted.
A couple of quick side notes:
Always use Option Explicit
Try to use more descriptive variable names. YOU know what you're talking about NOW. In a few months, you'll struggle to remember what d and Arr mean (even if it seems obvious now). It's just a good habit and makes the code self-documenting.
My example below breaks the logic into a separate function with an optional parameter (just for fun) that would allow the caller to change the start of the week to a different day.
Code module:
Option Explicit
Sub w_test()
Dim initialDate As Date
Dim finaldate As Date
initialDate = #5/5/2015#
finaldate = #9/29/2017#
Dim weeks As Variant
weeks = WeekNumbers(initialDate, finaldate)
Debug.Print "There are " & UBound(weeks, 1) & " weeks between " & _
Format(initialDate, "dd-mmm-yyyy") & " and " & _
Format(finaldate, "dd-mmm-yyyy")
End Sub
Private Function WeekNumbers(ByVal initialDate As Date, _
ByVal finaldate As Date, _
Optional ByVal weekStart As VbDayOfWeek = vbSunday) As Variant
Dim numberOfWeeks As Long
numberOfWeeks = DateDiff("ww", initialDate, finaldate, weekStart, vbFirstFullWeek)
Dim startOfWeek As Date
If Weekday(initialDate) <> vbSunday Then
Dim adjustBy As Long
If Weekday(initialDate) > weekStart Then
adjustBy = Weekday(initialDate) - weekStart
Else
adjustBy = (Weekday(initialDate) + 7) - weekStart
End If
startOfWeek = DateAdd("d", -adjustBy, initialDate)
End If
Dim allTheWeeks As Variant
ReDim allTheWeeks(1 To numberOfWeeks)
Dim weekInfo As Variant
ReDim weekInfo(1 To 3)
Dim i As Long
For i = 1 To numberOfWeeks
weekInfo(1) = startOfWeek
weekInfo(2) = DatePart("ww", startOfWeek, weekStart, vbFirstFourDays)
weekInfo(3) = Year(startOfWeek)
allTheWeeks(i) = weekInfo
startOfWeek = DateAdd("ww", 1, startOfWeek)
Next i
WeekNumbers = allTheWeeks
End Function
I have a document with the following:
FullDateTime FullDate FullTime Day Month Year Hour Minute Second
dd/mm/yyyy hh:mm:ss AM/PM
and I would like to fill in the other columns using macros to split the first column and place the whole date, whole time, day, month, year, hour, minute and second in the other columns. FullDateTime is every five minutes and I want to the DateTime to run for a whole year. I imagine the code to look something like:
Sub Func()
Dim 5mindays as Integer = 12*24*365
Dim x As Integer
Dim date
Dim time
For x = 1 To 5mindays
Split(," ")
Split(,"/")
Split(,":")
.Offset(0,1) = date(0)
...
.Offset(0,8) = time(2)
Add the next FullDateTime field below the existing one (adding 5 minutes)
Next
But have no idea how to actually do it. Please give me some ideas on how to solve this. Thanks!
Try after setting the correct worksheet name and year to process,
Option Explicit
Sub funk()
Dim dt As Long, yr As Long, tm As Long, dttm As Double
yr = 2018
dt = DateSerial(yr, 1, 1)
With Worksheets("sheet6")
Do While Year(dt) = yr
Do While TimeSerial(0, tm * 5, 0) < 1
dttm = dt + TimeSerial(0, tm * 5, 0)
.Cells(tm + 1 + (dt - DateSerial(yr, 1, 1)) * 288, "A").Resize(1, 9) = _
Array(dttm, dt, dttm - dt, _
Day(dt), Month(dt), yr, _
Hour(dttm), Minute(dttm), 0)
tm = tm + 1
Loop
tm = 0
dt = dt + 1
Loop
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "I").End(xlUp))
.Columns("A").NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
.Columns("B").NumberFormat = "dd/mm/yyyy"
.Columns("C").NumberFormat = "hh:mm:ss"
.Columns("D:I").NumberFormat = "0"
End With
End With
End Sub
I've been staring at this for so long and I honestly have no clue how to do it. Assume I have Sheet1 which has Employee ID in column A and Salary in column B for January 2016, and Employee ID and Salary in column A and B for December 2016 on Sheet2. How would I go about writing a for loop that finds the max percent difference in salaries based on employer ID? I would need to use some form of Vlookup since they don't match exactly.
Currently, this is what I have:
Sub Max_Percent_Change()
Dim Salary
For Each Cell In Worksheets("Sheet1").Range("A2:A1000")
Salary = Application.WorksheetFunction.VLookup(Cell, _
Worksheets("Sheet2").Range("A2:B1000"), 2, False)
If data is setup as shown in the images, please give this a try...
Change the sheet names if required in the code.
Sub FindSalaryPercentageChange()
Dim wsJan As Worksheet, wsDec As Worksheet
Dim x, y, z()
Dim i As Long
Dim janSalary As Double, decSalary As Double
Dim pChng As Double
Dim r
Application.ScreenUpdating = False
Set wsJan = Sheets("January16")
Set wsDec = Sheets("December16")
x = wsJan.Range("A1").CurrentRegion.Value
y = wsDec.Range("A1").CurrentRegion.Value
ReDim z(1 To UBound(x, 1) - 1)
wsDec.Columns("C").Clear
For i = 2 To UBound(y, 1)
r = Application.Match(y(i, 1), Application.Index(x, , 1), 0)
If Not IsError(r) Then
janSalary = x(r, 2)
decSalary = y(i, 2)
pChng = (decSalary - janSalary) / janSalary
z(i - 1) = pChng
End If
Next i
wsDec.Range("C1").Value = "%Change"
wsDec.Range("C2").Resize(UBound(z)).Value = Application.Transpose(z)
wsDec.Columns(3).NumberFormat = "0.00%"
Application.ScreenUpdating = True
End Sub
January16 Data:
December16 Data: