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
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)
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.
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
How can I improve my current approach to essentially get from Table 1 to Table 2?
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