Calculations with VBA: Sum Product and Rate Lookup

**hasan mougharbel** · 12-21-2023, 03:09 PM

Hello everyone,
I hope you're all doing well today. I have a straightforward calculation that I intend to execute using VBA instead of direct sheet formulas. I'm specifically focusing on the yellow highlighted columns for this task.

The given sheet already calculates the sum of working hours for each employee in every row.

Now, I need to calculate the wage for each row, as indicated in column I. The formula in column I is simply (F2 * 24) * 0.54. Note that 24 is a constant, while the number 0.54 is variable based on the individual's hourly rate, as shown in table hour_rate (in Sheet2).

So, I guess it is a VLOOKUP code that would retrieve the value of 0.54 from Sheet2. Hence, when this is achieved, I intend to perform a sum product operation on the values in column I, and the sum should consider only rows where the person is the same and has the same PRO. number simultaneously. These sum product values are calculated in column J.

I've populated a few rows to illustrate the data. Please find below the VBA code for which a vba code may be added.

Option Explicit

Sub Work_Time()
    Dim etime As Date, wktime As Double, sTime As Double
    Dim WE_Time
    Dim a
    Dim i As Long, idate As Long, sdate As Long, edate As Long, wk_day As Integer

    Const WS_time = "08:00:00"
    WE_Time = Array("19:00", "17:00", "14:00")

    Application.ScreenUpdating = False

    a = ActiveSheet.UsedRange.Value

    For i = 2 To UBound(a, 1)

        sdate = Int(a(i, 4)): edate = Int(a(i, 5))
        wktime = 0
        If sdate = edate Then                                                     ' Start & finish on the same day
            wktime = a(i, 5) - a(i, 4)
        Else
            For idate = sdate To edate                                             ' Loop FROM to TO dates
                wk_day = Weekday(idate, vbMonday)                                 ' Get Weekday
                If wk_day < 6 Then                                                ' Monday to Friday
                    etime = WE_Time(0)
                Else
                    If wk_day = 6 Then etime = WE_Time(1) Else etime = WE_Time(2) ' Saturday or Sunday
                End If
                Select Case idate
                    Case Is = sdate                                               ' Start Date
                        sTime = (a(i, 4) - Int(a(i, 4)))
                        wktime = wktime + (etime - sTime)
                    Case Is = edate                                               ' End Date
                        etime = (a(i, 5) - Int(a(i, 5)))
                        wktime = wktime + (etime - TimeValue(WS_time))
                    Case Else                                                      ' "In-between" dates
                        wktime = wktime + (etime - sTime)
                End Select
            Next idate
        End If

        ' Adjust wktime based on values in columns G and H
        If a(i, 7) > 0 Then  ' Check if value in column G is greater than 1
            wktime = wktime - a(i, 7)  ' Reduce value in column G from wktime
        End If
        If a(i, 8) > 0 Then  ' Check if value in column H is greater than 1
            wktime = wktime + a(i, 8)  ' Add value in column H to wktime
        End If

        a(i, 6) = wktime
    Next i

    ActiveSheet.UsedRange.Value = a

    Application.ScreenUpdating = True
End Sub

I appreciate your assistance in implementing these calculations using VBA.

Thank you very much!

Attached is my whole file as for your sole convenience.

**JohnTopley** · 12-21-2023, 03:41 PM

Option Explicit

Sub Work_Time()
    Dim etime As Date, wktime As Double, sTime As Double
    Dim WE_Time
    Dim a
    Dim i As Long, idate As Long, sdate As Long, edate As Long, wk_day As Integer
    Dim lr As Long
    
    Const WS_time = "08:00:00"
    WE_Time = Array("19:00", "17:00", "14:00")

    Application.ScreenUpdating = False

    a = ActiveSheet.UsedRange.Value
    lr = Cells(Rows.Count, "B").End(xlUp).Row

    For i = 2 To lr

        sdate = Int(a(i, 4)): edate = Int(a(i, 5))
        wktime = 0
        If sdate = edate Then                                                     ' Start & finish on the same day
            wktime = a(i, 5) - a(i, 4)
        Else
            For idate = sdate To edate                                             ' Loop FROM to TO dates
                wk_day = Weekday(idate, vbMonday)                                 ' Get Weekday
                If wk_day < 6 Then                                                ' Monday to Friday
                    etime = WE_Time(0)
                Else
                    If wk_day = 6 Then etime = WE_Time(1) Else etime = WE_Time(2) ' Saturday or Sunday
                End If
                Select Case idate
                    Case Is = sdate                                               ' Start Date
                        sTime = (a(i, 4) - Int(a(i, 4)))
                        wktime = wktime + (etime - sTime)
                    Case Is = edate                                               ' End Date
                        etime = (a(i, 5) - Int(a(i, 5)))
                        wktime = wktime + (etime - TimeValue(WS_time))
                    Case Else                                                      ' "In-between" dates
                        wktime = wktime + (etime - sTime)
                End Select
            Next idate
        End If

        ' Adjust wktime based on values in columns G and H
        If a(i, 7) > 0 Then  ' Check if value in column G is greater than 1
            wktime = wktime - a(i, 7)  ' Reduce value in column G from wktime
        End If
        If a(i, 8) > 0 Then  ' Check if value in column H is greater than 1
            wktime = wktime + a(i, 8)  ' Add value in column H to wktime
        End If

        a(i, 6) = wktime
        a(i, 9) = a(i, 6) * 24 * Application.VLookup(a(i, 2), Range("Rate_tbl"), 3, 0)
        
    Next i

    ActiveSheet.UsedRange.Value = a
    
    Dim rng As Range
    Set rng = Range("J2:J" & Cells(Rows.Count, "B").End(xlUp).Row)
    With rng
        .Formula = "=SUMIFS(I:I,B:B,B2)"
        .Value = .Value
    End With
    
    Application.ScreenUpdating = True
End Sub

NOTE: changed table ("Rate_Tbl") in Sheet2 as VLOOKUP search parameter has to be FIRST in the range

**hasan mougharbel** · 12-21-2023, 03:52 PM

Hey John,

Your solution is working perfectly. However, I anticipate a need to update the hourly rates in Sheet2. When I make these changes, I'd like to preserve the calculations based on the previous rates and only apply the new rates to future calculations. How can we manage this effectively?

**JohnTopley** · 12-21-2023, 04:05 PM

You will need to add a "Date Effective" for each person [and or table] to your rate table which allows the comparison of the Start / End dates with this date.

You need also to consider that a "Date Effective" COULD occur between "Start/End" dates so there are 2 rates to consider in this scenario

.

**hasan mougharbel** · 12-21-2023, 04:31 PM

Hi John,
I've understood your suggestion. In this scenario, I formulate a new table in Sheet2.
I assume in my case that when the start date matches the effective date that i enter in cell F2 on Sheet2, that specific hourly rate should be considered.
For any other cases, your previous code should handle it as before.

To clarify, if there is no effective date specified, or if the start date is before the effective date, the original hourly rate remains effective.
Only when there is a matching start date with the specified effective date should the new rate come into play.
I appreciate your guidance on how to incorporate these adjustments.
Thank you.

**JohnTopley** · 12-21-2023, 04:43 PM

Why post a w/book that does not have the LATEST code produced [i.e that from post #2] ?

**JohnTopley** · 12-21-2023, 05:04 PM

Option Explicit

Sub Work_Time()
    Dim etime As Date, wktime As Double, sTime As Double
    Dim WE_Time, eff_date As Long
    Dim a
    Dim i As Long, idate As Long, sdate As Long, edate As Long, wk_day As Integer
    Dim lr As Long
    
    Const WS_time = "08:00:00"
    WE_Time = Array("19:00", "17:00", "14:00")

    Application.ScreenUpdating = False
    
    Sheets("Data").Activate

    a = ActiveSheet.UsedRange.Value
    lr = Cells(Rows.Count, "B").End(xlUp).Row                                     ' Last row of data

    For i = 2 To lr

        sdate = Int(a(i, 4)): edate = Int(a(i, 5))
        wktime = 0
        If sdate = edate Then                                                     ' Start & finish on the same day
            wktime = a(i, 5) - a(i, 4)
        Else
            For idate = sdate To edate                                            ' Loop FROM to TO dates
                wk_day = Weekday(idate, vbMonday)                                 ' Get Weekday
                If wk_day < 6 Then                                                ' Monday to Friday
                    etime = WE_Time(0)
                Else
                    If wk_day = 6 Then etime = WE_Time(1) Else etime = WE_Time(2) ' Saturday or Sunday
                End If
                Select Case idate
                    Case Is = sdate                                               ' Start Date
                        sTime = (a(i, 4) - Int(a(i, 4)))
                        wktime = wktime + (etime - sTime)
                    Case Is = edate                                               ' End Date
                        etime = (a(i, 5) - Int(a(i, 5)))
                        wktime = wktime + (etime - TimeValue(WS_time))
                    Case Else                                                      ' "In-between" dates
                        wktime = wktime + (etime - sTime)
                End Select
            Next idate
        End If

        ' Adjust wktime based on values in columns G and H
        If a(i, 7) > 0 Then  ' Check if value in column G is greater than 1
            wktime = wktime - a(i, 7)  ' Reduce value in column G from wktime
        End If
        If a(i, 8) > 0 Then  ' Check if value in column H is greater than 1
            wktime = wktime + a(i, 8)  ' Add value in column H to wktime
        End If

        a(i, 6) = wktime                                                               ' Hours worked
        eff_date = Application.VLookup(a(i, 2), Range("Rate_tbl"), 4, 0)               ' look for Effective Date
        If eff_date <> 0 And sdate >= eff_date Then                                  ' If Sdate >= Effective date
            a(i, 9) = a(i, 6) * 24 * Application.VLookup(a(i, 2), Range("Rate_tbl"), 5, 0) ' Get new Hourly rate
        Else
            a(i, 9) = a(i, 6) * 24 * Application.VLookup(a(i, 2), Range("Rate_tbl"), 3, 0) ' Get Hourly rate
        End If
    Next i

    ActiveSheet.UsedRange.Value = a
    
    With Range("J2:J" & lr)
        .Formula = "=SUMIFS(I:I,B:B,B2)"                                        ' Calculate TOTAl earnings per employee
        .Value = .Value
    End With
    
    Application.ScreenUpdating = True
    
End Sub

changed dates in row 2

**JohnTopley** · 12-21-2023, 05:22 PM

And what happens when the "new" effective date expires ????

**hasan mougharbel** · 12-30-2023, 06:35 AM

Hi John, I hope you're doing well. I apologize for the delay in responding. I've discussed your proposed effective date solution with my teammates, and they've decided to implement it. In the event that the effective date expires, the plan is to transition to another sheet. Thank you so much for your code – your solution has significantly streamlined our processes. Your assistance is greatly appreciated.

**hasan mougharbel** · 12-21-2023, 04:50 PM

Ah, you're right..here is the new updated workbook

Calculations with VBA: Sum Product and Rate Lookup

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Re: Calculations with VBA: Sum Product and Rate Lookup

Thread Information

Users Browsing this Thread

Similar Threads

Monthly run rate calculations with FROM and TO dates

[SOLVED] Find Out Nearest rate more or less from data for particular product

Electricity Calculations based on Peak and Off Peak Rate

Conversion rate calculations with PowerPivots ?

Select product, show unit price, enter qty, driven by early/late rate = total

Calculations (pro-rate)

Product Master TI HI calculations/formula

Bookmarks

Bookmarks

Posting Permissions