Using range.find with an offset

figuare9

Board Regular
Joined
Oct 23, 2017
Messages
118
Name (Column AD)Category (AE)Total Hrs (AF)Pay Rate (AG)Wage (AH)
John Doe 1TT Field12.5
$104.55/hr

<tbody>
</tbody>
$1,306.88

<tbody>
</tbody>
John Doe 2TT Field4
$104.55/hr

<tbody>
</tbody>
$418.20

<tbody>
</tbody>
John Doe 3Field15
$34.85/hr

<tbody>
</tbody>
$522.75

<tbody>
</tbody>
John Doe 4Field37
$34.85/hr

<tbody>
</tbody>
$1,289.45

<tbody>
</tbody>
John Doe 5Field8
$30.70/hr

<tbody>
</tbody>
$245.60

<tbody>
</tbody>
John Doe 6Field15
$27.95/hr

<tbody>
</tbody>
$419.25

<tbody>
</tbody>
John Doe 7Field
$34.85/hr

<tbody>
</tbody>
$34.85/hr

<tbody>
</tbody>
$1,289.45

<tbody>
</tbody>

<tbody>
</tbody>


Bit stumped here. I'm not sure what I've been having issues with, but after this morning, I just deleted all my vba and started from scratch. I'm not sure if it's because the data I'm searching has a"/hr" and it's causing issues with finding it, but either way, I'm lost here.


I'm looking for a way to program a command button that can do the following.

* Search Column AG (pay rate) in range AG5:AG148 for all similar entries, and then add the number of hours in AF (Total Hrs Column) for all similar pay rates. There can be up to 168 different pay rates that could be in this column, so we would need to come up with a way that can search for identicals.
- For example, there might be 20 people with the same pay rate, so I'm looking to easily add the total hours for each unique pay rate.


Name (Column AD)Category (AE)Total Hrs (AF)Pay Rate (AG)Wage (AH)
John Doe 1TT Field12.5
$104.55/hr

<tbody>
</tbody>
$1,306.88

<tbody>
</tbody>
John Doe 2TT Field4
$104.55/hr

<tbody>
</tbody>
$418.20

<tbody>
</tbody>
John Doe 3Field15
$34.85/hr

<tbody>
</tbody>
$522.75

<tbody>
</tbody>
John Doe 4Field37
$34.85/hr

<tbody>
</tbody>
$1,289.45

<tbody>
</tbody>
John Doe 5Field8
$30.70/hr

<tbody>
</tbody>
$245.60

<tbody>
</tbody>
John Doe 6Field15
$27.95/hr

<tbody>
</tbody>
$419.25

<tbody>
</tbody>
John Doe 7Field
37

<tbody>
</tbody>
$34.85/hr

<tbody>
</tbody>
$1,289.45

<tbody>
</tbody>

<tbody>
</tbody>


So in this example, the outcome I'm looking for is basically the sum of all unique pay rates. (My workbook is empty after column AI. So we can output any data anywhere after that)

- pay rate 104.55 has 16.5
- Pay rate 34.85 has 89 hours
- pay rate 30.70 has 8 hours
- pay rate 27.95 has 15 hours



My workflow is this..

I get a CSV export from my payroll that looks quite a bit like the example tables above. Then I would take the information from there, copy it into another sheet I use, and count all the hours. Looking to streamline this and be a bit more efficient, because right now I'm using a calculator.. and it takes FOREVER! It'd be really nice if I could just copy and paste it into my range on my sheet, and click a button to auto sum all of the unique pay rates. It would save me several hours a week.

I would really appreciate any help from this!
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
240
Here's my take on a solution.

I used an ArrayList to make sorting and removing duplicates easier. I then converted to an array to make sorting by numbers easier (sorting the ArrayList by text doesn't put the numbers in numerical order).

Code:
Sub RateTotals()
    Dim payRateRange As Range
    Dim coll As Object, i As Long
    Dim payRates As String, d As Double
    Dim aRatesAsDbl() As Double, totalsRange As Range
    
    Set payRateRange = Range(Range("AG5"), Range("AG5").End(xlDown))
    Set totalsRange = Range("AJ1")

    'Create collection for removing duplicates
    Set coll = CreateObject("System.Collections.ArrayList")
    For i = LBound(payRateRange.value, 1) To UBound(payRateRange.value, 1)
        coll.Add payRateRange(i, 1).value
    Next i
    
    'Remove duplicates
    coll.Sort
    For i = coll.Count - 1 To 1 Step -1
        If coll(i) = coll(i - 1) Then
            coll.RemoveAt i
        End If
    Next i
    
    'Copy to array as numbers
    ReDim aRatesAsDbl(coll.Count - 1)
    For i = coll.Count - 1 To 0 Step -1
        aRatesAsDbl(i) = Mid(coll(i), 2, Len(coll(i)) - 4)
    Next i
    
    'Sort number array in descending order
    Dim sorted As Boolean
    Do While Not sorted
        sorted = True
        For i = 0 To UBound(aRatesAsDbl) - 1
            If aRatesAsDbl(i) < aRatesAsDbl(i + 1) Then
                d = aRatesAsDbl(i)
                aRatesAsDbl(i) = aRatesAsDbl(i + 1)
                aRatesAsDbl(i + 1) = d
                sorted = False
                Exit For
            End If
        Next i
    Loop
    
    'Find totals from sorted numbers
    For i = 0 To UBound(aRatesAsDbl)
        payRates = "$" & aRatesAsDbl(i) & "/hr"
        'Correct string if the zero in the ones place was removed when
        '   converting to double above
        If Mid(payRates, Len(payRates) - 4, 1) = "." Then
            payRates = "$" & aRatesAsDbl(i) & "0/hr"
        End If
        totalsRange.Offset(i, 0).value = payRates
        totalsRange.Offset(i, 1).value = findAllWages(payRateRange, payRates)
    Next i
End Sub

Function findAllHours(findRange As Range, payRate As String) As Double
    Dim FoundCell As Range
    Dim LastCell As Range
    Dim FirstAddr As String
    Dim d As Double
    
    With findRange
        Set LastCell = .Cells(.Cells.Count)
    End With
    Set FoundCell = findRange.Find(what:=payRate, after:=LastCell)
    
    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    Do Until FoundCell Is Nothing
        d = d + FoundCell.Offset(0, -1).value
        Set FoundCell = findRange.FindNext(after:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    findAllHours = d
End Function
 

figuare9

Board Regular
Joined
Oct 23, 2017
Messages
118
Thank you for the quick response on this! Very well commented too btw. I can't seem to get it working though..

- Made a new command button, pasted code, and I'm getting the function or sub not defined when clicking it... I'm troubleshooting now.. But this is over my head. :) I'll look into it though in the meantime.

Edit: Looks like the line "totalsRange.Offset(i, 1).Value = findAllWages(payRateRange, payRates)" isn't declared. Am I even close? lol! (I'm learning) :D
 
Last edited:

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
240
Yeah, sorry. My bad. I had renamed findAllHours in the HTML code after copying it from Excel but forgot that line. Change the Wages to Hours.
 

figuare9

Board Regular
Joined
Oct 23, 2017
Messages
118
Thank you very much for the help with this. It's amazing. I hope I can pay it forward eventually when I learn more.

I appreciate this immensely. You sir, are a good man! It works exactly as intended!
 
Last edited:

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,060
Office Version
2010
Platform
Windows
Just noting that you could probably have made this easier on yourself if, instead of physically putting the "/hr" text into each cell, you had used a Custom Format that displayed it instead... that way, your cells would have contained real numbers that you could easily performed math with. Here is the Custom Format I am thinking of...

$0.00"/hr"

Using it, all you would have to do is type in the number by itself (no $ sign and no trailing text). So, if you entered 12.34 the Custom Format would make it display this way...

$12.34/hr
 

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
240
You're welcome. Glad to help.

Rick's comments might be helpful for you, but I assumed that the CSV you got from finance already had all of the text including the /hr in it. If not, you can see if his comments can additionally help.
 

figuare9

Board Regular
Joined
Oct 23, 2017
Messages
118
You're welcome. Glad to help.

Rick's comments might be helpful for you, but I assumed that the CSV you got from finance already had all of the text including the /hr in it. If not, you can see if his comments can additionally help.

You were 100% right to assume that it had the "/hr" format in it from the CSV.

Also, I did some testing with this. We have a pay rate that is 42.00 /hr even.. For some reason, the code you gave me is skipping over this one. It seems that if the rate is an even number with a .00 on the end, it won't add it. I did some testing, and it fails to add any numbers together that don't have any "change".

Any chance you know what could be causing this?

Amazing btw. I never thought I would be excited to do billing.... lol!
 

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
240
Any chance you know what could be causing this?
Yes. I already had accounted for a rate of an even tens in the cents column, but I didn't account for no cents at all. This code fixes that. The problem enters when converting the string to a number. At this point, any trailing zeroes are lost. Therefore, we have to put them back in. That's what the If block in the last For loop does.

Code:
Sub RateTotals()
    Dim payRateRange As Range
    Dim coll As Object, i As Long
    Dim payRates As String, d As Double
    Dim aRatesAsDbl() As Double, totalsRange As Range
    
    Set payRateRange = Range(Range("AG5"), Range("AG5").End(xlDown))
    Set totalsRange = Range("AJ1")

    'Create collection for removing duplicates
    Set coll = CreateObject("System.Collections.ArrayList")
    For i = LBound(payRateRange.Value, 1) To UBound(payRateRange.Value, 1)
        coll.Add payRateRange(i, 1).Value
    Next i
    
    'Remove duplicates
    coll.Sort
    For i = coll.Count - 1 To 1 Step -1
        If coll(i) = coll(i - 1) Then
            coll.RemoveAt i
        End If
    Next i
    
    'Copy to array as numbers
    ReDim aRatesAsDbl(coll.Count - 1)
    For i = coll.Count - 1 To 0 Step -1
        aRatesAsDbl(i) = Mid(coll(i), 2, Len(coll(i)) - 4)
    Next i
    
    'Sort number array in descending order
    Dim sorted As Boolean
    Do While Not sorted
        sorted = True
        For i = 0 To UBound(aRatesAsDbl) - 1
            If aRatesAsDbl(i) < aRatesAsDbl(i + 1) Then
                d = aRatesAsDbl(i)
                aRatesAsDbl(i) = aRatesAsDbl(i + 1)
                aRatesAsDbl(i + 1) = d
                sorted = False
                Exit For
            End If
        Next i
    Loop
    
    'Find totals from sorted numbers
    For i = 0 To UBound(aRatesAsDbl)
        payRates = "$" & aRatesAsDbl(i) & "/hr"
        'Correct string if the zero in the ones place was removed when
        '   converting to double above
        If Mid(payRates, Len(payRates) - 4, 1) = "." Then
            payRates = "$" & aRatesAsDbl(i) & "0/hr"
        ElseIf InStr(1, payRates, ".") < 1 Then
            payRates = "$" & aRatesAsDbl(i) & ".00/hr"
        End If
        totalsRange.Offset(i, 0).Value = payRates
        totalsRange.Offset(i, 1).Value = findAllHours(payRateRange, payRates)
    Next i
End Sub

Function findAllHours(findRange As Range, payRate As String) As Double
    Dim FoundCell As Range
    Dim LastCell As Range
    Dim FirstAddr As String
    Dim d As Double
    
    With findRange
        Set LastCell = .Cells(.Cells.Count)
    End With
    Set FoundCell = findRange.Find(what:=payRate, after:=LastCell)
    
    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    Do Until FoundCell Is Nothing
        d = d + FoundCell.Offset(0, -1).Value
        Set FoundCell = findRange.FindNext(after:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    findAllHours = d
End Function
 

figuare9

Board Regular
Joined
Oct 23, 2017
Messages
118
Yes. I already had accounted for a rate of an even tens in the cents column, but I didn't account for no cents at all. This code fixes that. The problem enters when converting the string to a number. At this point, any trailing zeroes are lost. Therefore, we have to put them back in. That's what the If block in the last For loop does.

Code:
Sub RateTotals()
    Dim payRateRange As Range
    Dim coll As Object, i As Long
    Dim payRates As String, d As Double
    Dim aRatesAsDbl() As Double, totalsRange As Range
    
    Set payRateRange = Range(Range("AG5"), Range("AG5").End(xlDown))
    Set totalsRange = Range("AJ1")

    'Create collection for removing duplicates
    Set coll = CreateObject("System.Collections.ArrayList")
    For i = LBound(payRateRange.Value, 1) To UBound(payRateRange.Value, 1)
        coll.Add payRateRange(i, 1).Value
    Next i
    
    'Remove duplicates
    coll.Sort
    For i = coll.Count - 1 To 1 Step -1
        If coll(i) = coll(i - 1) Then
            coll.RemoveAt i
        End If
    Next i
    
    'Copy to array as numbers
    ReDim aRatesAsDbl(coll.Count - 1)
    For i = coll.Count - 1 To 0 Step -1
        aRatesAsDbl(i) = Mid(coll(i), 2, Len(coll(i)) - 4)
    Next i
    
    'Sort number array in descending order
    Dim sorted As Boolean
    Do While Not sorted
        sorted = True
        For i = 0 To UBound(aRatesAsDbl) - 1
            If aRatesAsDbl(i) < aRatesAsDbl(i + 1) Then
                d = aRatesAsDbl(i)
                aRatesAsDbl(i) = aRatesAsDbl(i + 1)
                aRatesAsDbl(i + 1) = d
                sorted = False
                Exit For
            End If
        Next i
    Loop
    
    'Find totals from sorted numbers
    For i = 0 To UBound(aRatesAsDbl)
        payRates = "$" & aRatesAsDbl(i) & "/hr"
        'Correct string if the zero in the ones place was removed when
        '   converting to double above
        If Mid(payRates, Len(payRates) - 4, 1) = "." Then
            payRates = "$" & aRatesAsDbl(i) & "0/hr"
        ElseIf InStr(1, payRates, ".") < 1 Then
            payRates = "$" & aRatesAsDbl(i) & ".00/hr"
        End If
        totalsRange.Offset(i, 0).Value = payRates
        totalsRange.Offset(i, 1).Value = findAllHours(payRateRange, payRates)
    Next i
End Sub

Function findAllHours(findRange As Range, payRate As String) As Double
    Dim FoundCell As Range
    Dim LastCell As Range
    Dim FirstAddr As String
    Dim d As Double
    
    With findRange
        Set LastCell = .Cells(.Cells.Count)
    End With
    Set FoundCell = findRange.Find(what:=payRate, after:=LastCell)
    
    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    Do Until FoundCell Is Nothing
        d = d + FoundCell.Offset(0, -1).Value
        Set FoundCell = findRange.FindNext(after:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    findAllHours = d
End Function
Works perfectly.. Thank you so much!

I love how you explained where and what was causing the issue as well. You're a gentleman and a scholar! Thanks again! This is some really great stuff!

Amazing community & people here!!!!
 

Watch MrExcel Video

Forum statistics

Threads
1,102,907
Messages
5,489,661
Members
407,703
Latest member
Chibuzo

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top