How to break an amount to a defined multiple, with a defined start and end date, into totals for a week
Sample Data
Start with:
Table 1 Names
Type Start End XXX XYZ
A 2024-10-31 2024-11-13 48.25 47
B 2024-11-05 2024-11-14 0.75 80.5
C 2024-10-31 2024-10-31 5
Finish with:
Table 2
Type Name 2024-10-28 2024-11-04 2024-11-11
A XXX 9.75 23.75 14.75
A XYZ 9.5 23.25 14.25
B XXX 0 0.25 0.5
B XYZ 0 40.25 40.25
C XYZ 5 0 0
Goal:
So this is like an unpivot if I have the term correct. I am basically trying to break apart a qty by a given multiple. I then spread that base multiple across all days, and add the left over on the end and start days working inward until there is not left over. Then just to simplify things, sum the results by week starting on Monday.
Note: The QTY will always be an integer when divided by the designated multiple value.
Table 1 is in another workbook and is just a bunch of cells in a worksheet.
Table 2 is in the codes workbook and is a named table. I have it defined as a listobject.
Holidays are currently being ignored. (ie note a current factor)
What I have figured out.
- Take the count and divide it by the number of weekdays
- Round the result down by the multiple amount
- Determine the left over time
- Find the number of days with extra days
- Split the extra time days equally between start and end with end getting extra day when extra day count is odd.
- Somehow apply the base amount to all days
- Somehow apply the multiple amount to the start extra days
- Somehow apply the multiple amount to the end extra days
- somehow sum the hours by the appropriate week
- paste the hours into the results table at the appropriate intersection of date and "A-XXX" combo
My thought process on a spreadsheet
I am trying to wrap my head through this. I think I have the process thought out. I am trying to figure out how to do this in VBA. I am not the strongest with Arrays, but something tells me that an array would be the best approach for this.
code
This is my current code, and its completely a work in progress, and something in my the back of my head says it may need to be completely revamped in that end section (after the 888 For loop).
Private Sub LoadPPT_Click()
Dim frm As PPT_Picker_Form
Dim wbPPT As Workbook
Dim wsPPT As Worksheet
Dim rngTopLeft As Range, rngBotRight As Range, rngPPTTable As Range
Dim lngLastUsedRow As Long
Dim lngLastCol As Long
Dim rngTargetCell As Range
Dim rngNameRow As Range
Dim rngNameCellFirst As Range, rngNameCellLast As Range
Dim lngTimeStart As Long
Dim rngStartDateCol As Range
Dim rngEndDateCol As Range
Dim rngHours As Range
Dim InputTable As ListObject
Dim lngInsertRow As Long
Dim lngPPTRowCounter As Long
Dim lngPPTColCounter As Long
Dim dStartDate As Date
Dim dEndDate As Date
Dim lngWeeks As Long
Dim dTaskSM As Date
Dim dTaskEM As Date
Dim lngTaskDays As Long
Dim dbTaskHoursPerDay As Double
Dim dbTaskDayUnits As Double
Dim dbTaskExtraUnitDays As Long
Dim lngDayCoutner As Long
Dim TestDate As Date
Dim dbWeek1Hours As Double
Dim dbWeeknHours As Double
Dim dbWeekLhours As Bouble
'Public strPPTFilepath As String
'Public strProjectNumber As String
Set InputTable = Me.ListObjects("Forecast_Table")
Set frm = UserForms.Add(PPT_Picker_Form.Name)
frm.ListData = ThisWorkbook.Worksheets("Project Numbers").ListObjects("Project_Number_List").DataBodyRange
frm.show
If bCancelled Then
Exit Sub
End If
'Define PPT Table
Set wbPPT = Workbooks.Open(strPPTFilepath)
Set wsPPT = wbPPT.Worksheets("Fee Estimate")
'Find top left corner
With wsPPT.Cells
Set rngTopLeft = .Find("WBS Code", LookIn:=xlFormulas)
If rngTopLeft Is Nothing Then
'nothing found
'add a manual cell picker routine
End If
Set rngTopLeft = rngTopLeft.Offset(2, 0)
End With
'Find last row
lngLastUsedRow = wsPPT.Cells(wsPPT.Rows.count, rngTopLeft.Column).End(xlUp).Row
'find Right edge
With wsPPT.Cells
Set rngTargetCell = .Find("Name", LookIn:=xlFormulas, LookAt:=xlWhole)
'Assume first name is to the right of the cell containing "Name"
Set rngNameCellFirst = rngTargetCell.Offset(0, 1)
If rngTargetCell Is Nothing Then
'nothing found
'add a manual cell picker routine
End If
Do While rngTargetCell <> ""
Set rngTargetCell = rngTargetCell.Cells.Offset(0, 1)
lngLastCol = rngTargetCell.Column
Loop
Set rngNameCellLast = rngTargetCell.Cells.Offset(0, -1)
lngLastCol = lngLastCol - 1
Set rngTargetCell = .Find("Start Date", LookIn:=xlFormulas, LookAt:=xlWhole)
Set rngStartDateCol = wsPPT.Range(rngTargetCell.Offset(2, 0), wsPPT.Cells(lngLastUsedRow, rngTargetCell.Column))
Set rngTargetCell = .Find("End Date", LookIn:=xlFormulas, LookAt:=xlWhole)
Set rngEndDateCol = wsPPT.Range(rngTargetCell.Offset(2, 0), wsPPT.Cells(lngLastUsedRow, rngTargetCell.Column))
Set rngTargetCell = .Find("Units", LookIn:=xlFormulas, LookAt:=xlWhole)
Set rngHours = wsPPT.Range(rngTargetCell.Offset(2, 0), wsPPT.Cells(lngLastUsedRow, rngNameCellLast.Column))
End With
'Define PPT table
Set rngPPTTable = wsPPT.Range(rngTopLeft, wsPPT.Cells(lngLastUsedRow, lngLastCol))
Set rngNameRow = wsPPT.Range(rngNameCellFirst, rngNameCellLast)
InsertRow = TableLastUsedRow
' strProjectNumber
If InputTable.ListRows(InputTable.ListRows.count).Range.Row = InsertRow Then
InputTable.ListRows.Add AlwaysInsert:=True
InsertRow = InsertRow + 1
End If
For lngPPTRowCounter = 1 To 888
If WorksheetFunction.CountA(rngPPTTable.Row(lngPPTRowCounter)) <> 0 Then
InputTable.ListColumns("Project No").ListRow(InsertRow) = strProjectNumber
InputTable.ListColumns("Task No").ListRow(InsertRow) = rngPPTTable.Cells(PPTRowCounter, 2) & " - " & rngPPTTable.Cells(PPTRowCounter, 3)
InputTable.ListColumns("Staff").ListRow(InsertRow) = rngNameRow(PPTColCounter)
'Insert Funtcion to fill in Office Based on Name
dStartDate = rngStartDate(rngPPTRowCounter)
dEndDate = rngEndDate(rngPPTRowCounter)
dTaskSM = Monday_Date(dStartDate)
dTaskEM = Monday_Date(dEndDate)
lngTaskDays = WorksheetFunction.NetworkDays(dStartDate, dEndDate)
For lngPPTColCounter = 1 To 999
If rngHours(lngPPTRowCounter, lngPPTColCounter) > 0 Then
dbTaskHoursPerDay = WorksheetFunction.RoundDown((rngHours(lngPPTRowCounter, lngPPTColCounter) / lngTaskDays) / 0.25, 0) * 0.25
If dbTaskHoursPerDay = 0 Then
'Outside in fill to 0 routine
Else
dbTaskDayUnits = rngHours(lngPPTRowCounter, lngPPTColCounter) / dbTaskHoursPerDay
dbTaskExtraUnitDays = dbTaskDayUnits Mod lngTaskDays
TestDate = dStartDate
For lngDayCounter = 1 To (dEndate - dStartDate)
If Weekday(TestDate) > 1 And Weekday(TestDate) < 7 Then
If TestDate < dTaskSM + 5 Then
Week1hours= Week1Hours+
ElseIf TestDate < dTaskEM - 2 Then
Else
End If
Week1EndDate
Week2ndLastEndDate
End If
End If
Next lngPPTRowCounter
Next lngPPTColCounter
End Sub
Question
How can I improve my current approach to essentially get from Table 1 to Table 2?
Solution
I’m not sure I fully understand the logic of your question, but I believe it aims to distribute the workload (or other things) across each week. I’ve developed a different approach—please note the [Amt] and [Week] in the output, as they differ slightly from your results. If you find my output accurate, it can easily be converted into a 2D table format as you expected.
Sub demo2()
Dim sDate As Date, eDate As Date, sMonday As Date, eMonday As Date
Dim iDay As Long, dAmt As Double, dUnit As Double
' *** for debugging
sDate = #10/31/2024#
eDate = #11/13/2024#
dAmt = 48.25
' sDate = #10/31/2024#
' eDate = #11/13/2024#
' dAmt = 47
' ***
iDay = Application.NetworkDays(sDate, eDate)
dUnit = dAmt / iDay
sMonday = sDate + 1 - VBA.Weekday(sDate, vbMonday)
eMonday = eDate + 1 - VBA.Weekday(eDate, vbMonday)
Dim i As Date, WeekCnt As Long, iWorkDay As Long, iR As Long
Dim WkEnd As Date, dAmtInWK As Double, dAmtInWK0 As Double, dSum As Double
WeekCnt = (eMonday - sMonday) / 7 + 1
Dim aRes(): ReDim aRes(1 To WeekCnt, 4)
For i = sMonday To eMonday Step 7
WkEnd = i + 6
With Application
iWorkDay = .NetworkDays(.Max(i, sDate), .Min(WkEnd, eDate))
dAmtInWK0 = iWorkDay * dUnit
dAmtInWK = .RoundDown(iWorkDay * dUnit * 4, 0) / 4
End With
dSum = dSum + dAmtInWK
If i = eMonday Then
dAmtInWK = dAmtInWK + (dAmt - dSum) / 2
aRes(1, 1) = aRes(1, 1) + (dAmt - dSum) / 2
End If
iR = iR + 1
aRes(iR, 0) = i
aRes(iR, 1) = dAmtInWK
aRes(iR, 2) = iWorkDay
aRes(iR, 3) = dAmtInWK0
aRes(iR, 4) = dSum
Next
For i = 1 To WeekCnt
Debug.Print "[Week]:" & aRes(i, 0) & vbCr _
; "[Amt]:" & aRes(i, 1) & vbCr _
; "WorkingDay:" & aRes(i, 2) & vbCr _
; "Amt Before Round:" & aRes(i, 3) & vbCr _
; "Accumulated Amt:" & aRes(i, 4) & vbCr _
; " -------------------- "
Next
End Sub
Output:
[Week]:2024/10/28
[Amt]:9.75
WorkingDay:2
Amt Before Round:9.65
Accumulated Amt:9.5
--------------------
[Week]:2024/11/4
[Amt]:24
WorkingDay:5
Amt Before Round:24.125 ' Do u think it should be rounded to 24 instead of 23.75
Accumulated Amt:33.5
--------------------
[Week]:2024/11/11
[Amt]:14.5
WorkingDay:3
Amt Before Round:14.475
Accumulated Amt:47.75
Update:
Sub demo2()
Dim sDate As Date, eDate As Date, sMonday As Date, eMonday As Date
Dim iDay As Long, dAmt As Double, dUnit As Double
' *** for debugging
sDate = #10/31/2024#
eDate = #11/13/2024#
dAmt = 48.25
' sDate = #10/31/2024#
' eDate = #11/13/2024#
' dAmt = 47
' ***
iDay = Application.NetworkDays(sDate, eDate)
dUnit = Application.RoundDown(dAmt / iDay * 4, 0) / 4 '***
sMonday = sDate + 1 - VBA.Weekday(sDate, vbMonday)
eMonday = eDate + 1 - VBA.Weekday(eDate, vbMonday)
Dim i As Date, j As Long, WeekCnt As Long, iWorkDay As Long, iR As Long
Dim WkEnd As Date, dAmtInWK As Double, dAmtInWK0 As Double, dSum As Double
WeekCnt = (eMonday - sMonday) / 7 + 1
Dim aRes(): ReDim aRes(1 To WeekCnt, 4)
Dim dTmp As Double
For i = sMonday To eMonday Step 7
WkEnd = i + 6
With Application
iWorkDay = .NetworkDays(.Max(i, sDate), .Min(WkEnd, eDate))
dAmtInWK0 = iWorkDay * dUnit
dAmtInWK = .RoundDown(iWorkDay * dUnit * 4, 0) / 4
dSum = dSum + dAmtInWK
iR = iR + 1
aRes(iR, 0) = i
aRes(iR, 1) = dAmtInWK
aRes(iR, 2) = iWorkDay
aRes(iR, 3) = dAmtInWK0
aRes(iR, 4) = dSum
If i = eMonday Then ' distribute remainder
dTmp = (dAmt - dSum) / 0.25
Dim sOffset As Long, eOffset As Long
If dTmp Mod 2 = 0 Then
sOffset = dTmp / 2
Else
sOffset = (dTmp / 2) - 0.5
End If
eOffset = dTmp - sOffset
For j = 1 To WeekCnt
aRes(j, 1) = aRes(j, 1) + 0.25 * .Min(sOffset, aRes(j, 2))
sOffset = sOffset - aRes(j, 2)
If sOffset <= 0 Then Exit For
Next
For j = WeekCnt To 1 Step -1
aRes(j, 1) = aRes(j, 1) + 0.25 * .Min(eOffset, aRes(j, 2))
eOffset = eOffset - aRes(j, 2)
If eOffset <= 0 Then Exit For
Next
For j = 1 To WeekCnt ' for debugging
If j = 1 Then
dSum = aRes(j, 1)
Else
dSum = dSum + aRes(j, 1)
End If
aRes(j, 4) = dSum
Next
End If
End With
Next
For j = 1 To WeekCnt
Debug.Print "[Week]:" & aRes(j, 0) & vbCr _
; "[Amt]:" & aRes(j, 1) & vbCr _
; "WorkingDay:" & aRes(j, 2) & vbCr _
; "Amt Before Round:" & aRes(j, 3) & vbCr _
; "Accumulated Amt:" & aRes(j, 4) & vbCr _
; " -------------------- "
Next
End Sub
Output:
[Week]:2024/10/28
[Amt]:9.75
WorkingDay:2
Amt Before Round:9.5
Accumulated Amt:9.75
--------------------
[Week]:2024/11/4
[Amt]:23.75
WorkingDay:5
Amt Before Round:23.75
Accumulated Amt:33.5
--------------------
[Week]:2024/11/11
[Amt]:14.75
WorkingDay:3
Amt Before Round:14.25
Accumulated Amt:48.25
- How to import values from excel with pandas into tkinter faster?
- Speed up concatenation of excel files with Pandas
- Trying to send screenshot of excel in an email
- Sum of text Does not contain in Range
- Stopping Excel Macro executution when pressing Esc won't work
- Consolidated Date window
- Excel formula for calculating difference between two date columns
- Get number of decimals in python float, including trailing zeros
- Excel VBA search for data and stuck at a certain point due to group or split source file?
- Convert Time Input in Decimal Format - Excel Formula or VBA
- Lookup unique "Values" if they follow a certain "Pattern" from a lookup table then return a "Name"
- Share office scripts connected to Excel with external organisations
- Tiling an Excel array in 2 dimensions, ideally not using VBA
- How to get the cartesian product of two sets via Excel Formulas
- Repeat Value for Every Instance of Another Value in Excel without using Power Query
- VSTACK doesn't pile up dynamic ranges
- How To Close a UserForm Properly in Excel VBA?
- In Excel, can I use a hyperlink to run vba macro?
- EXCEL: Count all unique values in Table column up to a certain point, and combine them into a single string?
- Excel VBA connection to SQL Server with Microsoft Entra MFA authentication
- Excel shows incorrect polynomial trendline function
- Split too large VBA into multiple Subs
- Trying to calculate user whos spent the most and the least - Excel
- How to do a union of two columns and then sort them into a third column in Excel?
- Is there a way to create a simple custom formula in Excel without VBA?
- Copying a String Array into a Range of cells (in MS Excel using VBA)
- vlookup with formula calculated from lookup cell location
- How to extract R InstallPath from Registry using Excel VBA
- How to inner-join in Excel (eg. using VLOOKUP)
- Scientific notation when importing from Excel in .Net