excelvba

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.

  1. Take the count and divide it by the number of weekdays
  2. Round the result down by the multiple amount
  3. Determine the left over time
  4. Find the number of days with extra days
  5. Split the extra time days equally between start and end with end getting extra day when extra day count is odd.
  6. Somehow apply the base amount to all days
  7. Somehow apply the multiple amount to the start extra days
  8. Somehow apply the multiple amount to the end extra days
  9. somehow sum the hours by the appropriate week
  10. paste the hours into the results table at the appropriate intersection of date and "A-XXX" combo

My thought process on a spreadsheet enter image description here

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