vba find function assistance

J

jiddings

Board Regular
Joined
Nov 22, 2008
Messages
135
I have a spreadsheet that I need to collect data and copy it to a separate spreadsheet.
The source spreadsheet is configured as follows
Column A: Column B:
Employee: Employee clock #
Department: Department A
Reg Pay: daily hrs Sun - Sat(column B - Column H)
Department: Department B
Reg Pay: daily hrs Sun - Sat(column B - Column H)
Department: Department C
Reg Pay: daily hrs Sun - Sat(column B - Column H)
Employee: Employee clock #
Department: Department A
Reg Pay: daily hrs Sun - Sat(column B - Column H)
Department: Department B
Reg Pay: daily hrs Sun - Sat(column B - Column H)
Department: Department C
Reg Pay: daily hrs Sun - Sat(column B - Column H)

This repeats for approx. 60 employees.

As the employees are a shared resource between departments, not all employees work for each department each week and some work in only one department for a given week. Thus, other department designations will not appear for a given employee and will only appear if the employee works for that department during that week.
I've used the vba find function to locate each employee's clock #. I'm having difficulity with vba to locate Department "B" for each employee and I'm attempting to utilize the find function. Any recommendations on vba code to do this would be appreciated.
 
Sort by date Sort by votes
jiddings,

The original code was based on the consistent structure of the data. If not every employee working in department B has the HOLIDAY, VACATION, & BONUS DAY categories a different approach must be taken. I will take a look at it and get back to you. To be clear are you asking for 4 target sheets one for each category of hours or 2 target sheets 1 for reg hours and 1 for the other type of hours?
 
Upvote 0

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Thanks for asking ...
My intent is to: put HOLIDAY, VACATION, & BONUS DAY hours categories on a separate sheet and change the cell color for the different categories AND also put these same category hours on the sheet with REG PAY hours again changing the colors for these categories.
Here's some code I was working on to put the hours in once the clock # and categories were correctly found.

Thanks again for looking at this for me. Your help is definitely appreciated.

Code: 
cstart = Selection.Address
Range(cstart).Offset(0, 0).Select
'Range("B2").Offset(1, 0).Select

For k = 0 To 6
'WB_Source.WS_Source.Selection.Copy
WS_Source.Activate
Range(cstart).Offset(0, k).Select

Selection.Copy
'WS_Source.Cells(1, (3 + k)).Copy
WS_Target.Activate
WS_Target.Cells(TargetRow + k, ClNumCol).Select
WS_Source.Activate
'ActiveCell.Select
If Selection = 0 Then
'do nothing
Else
WS_Target.Activate
Selection.PasteSpecial xlPasteValues
End If
If Selection.Value <> 0 Then
'WS_Target.Cells(TargetRow + k, ClNumCol).Interior.Color = RGB(255, 0, 255) 'holiday color
'WS_Target.Cells(TargetRow + k, ClNumCol).Interior.Color = RGB(255, 153, 204) 'floating holiday color
WS_Target.Cells(TargetRow + k, ClNumCol).Interior.Color = RGB(51, 102, 255) 'vacation color
'WS_Target.Cells(TargetRow + k, ClNumCol).Interior.Color = RGB(153, 102, 255) 'bonus vac day color
WS_Target.Cells(TargetRow + k, ClNumCol).Font.Color = vbWhite 'font color
WS_Target.Cells(TargetRow + k, ClNumCol).Font.Bold = True 'font color

End If
'End With

Next k
 
Upvote 0
Added a loop to check for each category and apply the fill based on the category.

Code: 
Sub test()   
   Dim TargetWS As Worksheet
   Dim TargetWS2 As Worksheet
   Dim SourceWS As Worksheet
   
   Dim rngFound As Range
   Dim cell As Range
   
   Dim hrCategories(1 To 5) As String
   Dim RGBCategories(1 To 5)
   
   Dim LR As Long, outLR As Long, out2LR As Long
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   
   Set TargetWS = Sheets("Target")
   Set TargetWS2 = Sheets("Target2")
   Set SourceWS = Sheets("Source")
   
   hrCategories(1) = "REG PAY"
   RGBCategories(1) = 16777215  '// NO FILL
   
   hrCategories(2) = "HOLIDAY"
   RGBCategories(2) = RGB(255, 0, 255)
   
   hrCategories(3) = "FLOATING HOLIDAY"
   RGBCategories(3) = RGB(255, 153, 204)
   
   hrCategories(4) = "VACATION"
   RGBCategories(4) = RGB(51, 102, 255)
   
   hrCategories(5) = "BONUS PAY"
   RGBCategories(5) = RGB(153, 102, 255)
   
   '// Find all occurances "Employee" Function returns range
   Set rngFound = findAllRange("EMPLOYEE", SourceWS.Columns(1))
   '// Last row with data in column A
   
   
   LR = SourceWS.Cells(Rows.Count, 1).End(xlUp).Row
   
   '// Loop through Employeee ranges
   For Each cell In rngFound
       i = 1


        '// Loop column B Looking for Dept B
      Do


         '// When DEPT B is found look for Categoris field
         If InStr(1, cell.Offset(i, 1).Value, "DEPT B", vbTextCompare) > 0 Then
            '// loop through categories
            For j = LBound(hrCategories) To UBound(hrCategories)
               '// Determine last row of target sheets
               
               k = 1    '//Reset counter
               
               '// Loop until next employee or end of data
               Do
                 
                  '// Check if category is found
                  If InStr(1, cell.Offset(k, 0).Value, hrCategories(j), vbTextCompare) > 0 Then
                     outLR = TargetWS.Cells(Rows.Count, 1).End(xlUp).Row + 1
                     '// Copy Employee's Clock #
                     cell.Offset(0, 1).Copy Destination:=TargetWS.Cells(outLR, 1)
                     
                     '// Copy Hours
                     cell.Offset(k, 1).Resize(1, 7).Copy Destination:=TargetWS.Cells(outLR, 2)
                     TargetWS.Cells(outLR, 1).Resize(1, 8).Interior.Color = RGBCategories(j)
                     
                     '// Copy to Not reg pay sheet
                     If j <> 1 Then
                        out2LR = TargetWS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        '// Copy Employee's Clock #
                        cell.Offset(0, 1).Copy Destination:=TargetWS2.Cells(out2LR, 1)
                        '// Copy Hours
                        cell.Offset(k, 1).Resize(1, 7).Copy Destination:=TargetWS2.Cells(out2LR, 2)
                        TargetWS2.Cells(out2LR, 1).Resize(1, 8).Interior.Color = RGBCategories(j)
                     End If
                  End If '// Category Match
                  k = k + 1
                  
               Loop While InStr(1, cell.Offset(k, 0).Value, "EMPLOYEE", vbTextCompare) <= 0 And k + cell.Row <= LR
            Next '// J 1 to 4
            i = i + 1
         End If '// Dept B


         '// Exit do if the next employee is encounter or the loop reaches the end of the data
         If InStr(1, cell.Offset(i, 0).Value, "EMPLOYEE", vbTextCompare) > 0 Then GoTo nextCell
         i = i + 1
      Loop While i + cell.Row <= LR
nextCell:
    Next cell
End Sub
 
Upvote 0
Ralajer, Thanks for the VBA code.
During my check out of the code I noticed one "abnormality".
When copying the data for a employee that has dual department responsibility, (see previous post of employee with hrs. for two departments -- third one)) the code "collects" the hours from both hours.
How would I modify the code to correct this?

Again, thanks much for the updated VBA
 
Upvote 0
Correction in wording from previous post
When copying the data for a employee that has dual department responsibility, (see previous post of employee with hrs. for two departments -- third one in sample)) the code "collects" the hours from both departments.
 
Upvote 0
This should work I had to add a reference to the Dept B cell to avoid the the inner loop from catching the Dept A hours. I tested it and it all seems to be working good.

Code: 
Sub test()
   Dim TargetWS As Worksheet
   Dim TargetWS2 As Worksheet
   Dim SourceWS As Worksheet
   
   Dim rngFound As Range
   Dim cell As Range
   Dim empDeptBCell As Range
   
   Dim hrCategories(1 To 5) As String
   Dim RGBCategories(1 To 5)
   
   Dim LR As Long, outLR As Long, out2LR As Long
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   
   Set TargetWS = Sheets("Target")
   Set TargetWS2 = Sheets("Target2")
   Set SourceWS = Sheets("Source")
   
   hrCategories(1) = "REG PAY"
   RGBCategories(1) = 16777215  '// NO FILL
   
   hrCategories(2) = "HOLIDAY"
   RGBCategories(2) = RGB(255, 0, 255)
   
   hrCategories(3) = "FLOATING HOLIDAY"
   RGBCategories(3) = RGB(255, 153, 204)
   
   hrCategories(4) = "VACATION"
   RGBCategories(4) = RGB(51, 102, 255)
   
   hrCategories(5) = "BONUS PAY"
   RGBCategories(5) = RGB(153, 102, 255)
   
   '// Find all occurances "Employee" Function returns range
   Set rngFound = findAllRange("EMPLOYEE", SourceWS.Columns(1))
   '// Last row with data in column A
   
   LR = SourceWS.Cells(Rows.Count, 1).End(xlUp).Row
   
   '// Loop through Employeee ranges
   For Each cell In rngFound
       i = 1


        '// Loop column B Looking for Dept B
      Do


         '// When DEPT B is found look for Categoris field
         If InStr(1, cell.Offset(i, 1).Value, "DEPT B", vbTextCompare) > 0 Then
            Set empDeptBCell = cell.Offset(i, 0)
            '// loop through categories
            For j = LBound(hrCategories) To UBound(hrCategories)
               '// Determine last row of target sheets
               
               k = 1    '//Reset counter
               
               '// Loop until next employee or end of data
               Do
                 
                  '// Check if category is found
                  If UCase(empDeptBCell.Offset(k, 0).Value) = hrCategories(j) Then
                     outLR = TargetWS.Cells(Rows.Count, 1).End(xlUp).Row + 1
                     '// Copy Employee's Clock #
                     cell.Offset(0, 1).Copy Destination:=TargetWS.Cells(outLR, 1)
                     
                     '// Copy Hours
                     empDeptBCell.Offset(k, 1).Resize(1, 7).Copy Destination:=TargetWS.Cells(outLR, 2)
                     TargetWS.Cells(outLR, 1).Resize(1, 8).Interior.Color = RGBCategories(j)
                     
                     '// Copy to Not reg pay sheet
                     If j <> 1 Then
                        out2LR = TargetWS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        '// Copy Employee's Clock #
                        cell.Offset(0, 1).Copy Destination:=TargetWS2.Cells(out2LR, 1)
                        '// Copy Hours
                        empDeptBCell.Offset(k, 1).Resize(1, 7).Copy Destination:=TargetWS2.Cells(out2LR, 2)
                        TargetWS2.Cells(out2LR, 1).Resize(1, 8).Interior.Color = RGBCategories(j)
                     End If
                  End If '// Category Match
                  k = k + 1
                  
               Loop While InStr(1, empDeptBCell.Offset(k, 0).Value, "EMPLOYEE", vbTextCompare) <= 0 And k + cell.Row <= LR
            Next '// J 1 to 4
            i = i + 1
         End If '// Dept B


         '// Exit do if the next employee is encounter or the loop reaches the end of the data
         If InStr(1, cell.Offset(i, 0).Value, "EMPLOYEE", vbTextCompare) > 0 Then GoTo nextCell
         i = i + 1
      Loop While i + cell.Row <= LR
nextCell:
    Next cell
End Sub
 
Upvote 0
Thanks...
I'll check it out in the morning.
It is correct to presume this VBA will function for Dept. A by changing the designations from Dept. B to Dept. A ...... correct????
 
Upvote 0
Since you need something more generalized I converted the previous sub into a sub that is called from other subs. That way you can pass the Department and sheet references into the same code. See below.

This should be flexible enough so that if another department gets added you only need to make a new sub that call.
Code: 
Sub HoursFromDeptA()
    HoursByDept "DEPT A", Sheets("Source"), Sheets("Dept_A_All"), Sheets("Dept_A_Non-Reg")
End Sub

Sub HoursFromDeptB()
    HoursByDept "DEPT B", Sheets("Source"), Sheets("Dept_B_All"), Sheets("Dept_B_Non-Reg")
End Sub

Private Sub HoursByDept(dept As String, sourceWS As Worksheet, TargetWS1 As Worksheet, TargetWS2 As Worksheet)
   
   Dim rngFound As Range
   Dim cell As Range
   Dim DeptRefCell As Range
   
   Dim hrCategories(1 To 5) As String
   Dim RGBCategories(1 To 5)
   
   Dim LR As Long, outLR As Long, out2LR As Long
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer


   hrCategories(1) = "REG PAY"
   RGBCategories(1) = 16777215  '// NO FILL
   
   hrCategories(2) = "HOLIDAY"
   RGBCategories(2) = RGB(255, 0, 255)
   
   hrCategories(3) = "FLOATING HOLIDAY"
   RGBCategories(3) = RGB(255, 153, 204)
   
   hrCategories(4) = "VACATION"
   RGBCategories(4) = RGB(51, 102, 255)
   
   hrCategories(5) = "BONUS PAY"
   RGBCategories(5) = RGB(153, 102, 255)
   
   '// Find all occurances "Employee" Function returns range
   Set rngFound = findAllRange("EMPLOYEE", sourceWS.Columns(1))
   
   '// Last row with data in column A
   LR = sourceWS.Cells(Rows.Count, 1).End(xlUp).Row
   
   '// Loop through Employeee ranges
   For Each cell In rngFound
       i = 1


        '// Loop Column B Looking for selected department
      Do


         '// When selected departement is found look for category field
         If InStr(1, cell.Offset(i, 1).Value, dept, vbTextCompare) > 0 Then
            Set DeptRefCell = cell.Offset(i, 0)
            '// loop through categories
            For j = LBound(hrCategories) To UBound(hrCategories)
               k = 1    '//Reset counter
               '// Loop until next employee or end of data
               Do
                  If InStr(1, DeptRefCell.Offset(k, 1).Value, "DEPT", vbTextCompare) > 0 Then Exit Do
                  '// Check if category is found
                  If UCase(DeptRefCell.Offset(k, 0).Value) = hrCategories(j) Then
                     '// Determine last row of target sheet 1
                     outLR = TargetWS1.Cells(Rows.Count, 1).End(xlUp).Row + 1
                     '// Copy Employee's Clock #
                     cell.Offset(0, 1).Copy Destination:=TargetWS1.Cells(outLR, 1)
                     
                     '// Copy Hours
                     DeptRefCell.Offset(k, 1).Resize(1, 7).Copy Destination:=TargetWS1.Cells(outLR, 2)
                     TargetWS1.Cells(outLR, 1).Resize(1, 8).Interior.Color = RGBCategories(j)
                     
                     '// Copy to Not reg pay sheet
                     If j <> 1 Then
                        '// Determine last row of target sheet 2
                        out2LR = TargetWS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        '// Copy Employee's Clock #
                        cell.Offset(0, 1).Copy Destination:=TargetWS2.Cells(out2LR, 1)
                        '// Copy Hours
                        DeptRefCell.Offset(k, 1).Resize(1, 7).Copy Destination:=TargetWS2.Cells(out2LR, 2)
                        TargetWS2.Cells(out2LR, 1).Resize(1, 8).Interior.Color = RGBCategories(j)
                     End If
                  End If '// Category Match
                  k = k + 1
               '// End loop when next employee is reached or end of data is reached
               Loop While InStr(1, DeptRefCell.Offset(k, 0).Value, "EMPLOYEE", vbTextCompare) <= 0 And k + cell.Row <= LR
            Next '// J
            i = i + 1
         End If '// Selected department


         '// End for loop when next employee is reached
         If InStr(1, cell.Offset(i, 0).Value, "EMPLOYEE", vbTextCompare) > 0 Then GoTo nextCell
         i = i + 1
      Loop While i + cell.Row <= LR
nextCell:
    Next cell
End Sub
 
Upvote 0
Thanks for your most generous help.
My thought was to run one sub for Dept. A and one sub for Dept. B (both separate worksheets in the same workbook). Additionally, a third worksheet for tracking, holidays, etc. It appears that you've set it up for 4 worksheets, but I can work with it and it may be better than 3 worksheets.
Placing the VBA into one sub that is called by other subs appears to be a good refinement.

I'm still getting my mind around the looping process and I've learned a technique from you for using the INSTR function.
I'm still anticipating being asked (although it may not happen) for tracking other time-off categories, such as jury duty, bereavement, etc. Would I then adjust the hrCategories and RGBCategories by adding the new categories from the current 5 categories to 6, 7, etc. as necessary?

Once again, you have been a tremendous help, THANK YOU!
 
Upvote 0
This may sound inexperienced and I admit not much experience passing variables to another sub.
For this statement: HoursByDept "DEPT A", Sheets("Source"), Sheets("Dept_A_All"), Sheets("Dept_A_Non-Reg") could you please give me an example of passing the varables as I'm totally unsure and everything I try gives me an error.
What I have is a sub that requests the user to select the source workbook and I should be adding VBA in that sub to pass the variables. The sub as far as loading the source workbook is working well, but I know I need more VBA for the variables. I'm now very confused after various tries.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA to show and change list of names depending on selection
Replies
7
Views
749
mumps
mumps
O
  • Solved
VBA - floating photo
Replies
3
Views
492
RoryA
RoryA
D
  • Question Question
Can time frames/windows be used as a condition for any functions?
Replies
4
Views
124
dallas2699
D
L
  • Solved
VBA Find Cell from Date listed, in Columns, Return cell to highlight in color
Replies
7
Views
528
mumps
mumps
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
738
Domenic
D

Forum statistics

Threads
1,224,582
Messages
6,179,670
Members
452,936
Latest member
anamikabhargaw

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top