I am a supervisor, I get reports th

[maerts]

I am a supervisor, I get reports that I need to find all of the agents that work under me and highlight their rows, I have written some VB script that does this however it is very difficult to change as I add or delete someone from my team, I am sure there is a way to do this without specifing each person and doing a macro for each person. Is there a way to have the macro look at a "list" and search for each person and highlight them? This is the VB that I am currently using:

Sub JohnDoe()

For counter = 1 To 20
On Error GoTo MyErrorHandler
Cells.Find(What:="John Doe", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True).EntireRow.Select
Selection.Interior.ColorIndex = 3
ActiveCell.Offset(1, 0).Range("A1&quot.Select
Next counter
Application.Run "PERSONAL.XLS!JaneDoe"
Exit Sub
MyErrorHandler:
If Err.Number = 91 Then
Application.Run "PERSONAL.XLS!JaneDoe"
End If
End Sub

Sub JaneDoe()

For counter = 1 To 20
On Error GoTo MyErrorHandler
Cells.Find(What:="Jane Doe", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True).EntireRow.Select
Selection.Interior.ColorIndex = 3
ActiveCell.Offset(1, 0).Range("A1&quot.Select
Next counter
Application.Run "PERSONAL.XLS!JohnSmith"
Exit Sub
MyErrorHandler:
If Err.Number = 91 Then
Application.Run "PERSONAL.XLS!JohnSmith"
End If
End Sub

Sub JohnSmith()

For counter = 1 To 20
On Error GoTo MyErrorHandler
Cells.Find(What:="John Smith", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True).EntireRow.Select
Selection.Interior.ColorIndex = 3
ActiveCell.Offset(1, 0).Range("A1&quot.Select
Next counter
MsgBox ("Done&quot
Exit Sub
MyErrorHandler:
If Err.Number = 91 Then
MsgBox ("Done&quot
End If
End Sub



I have over 50 agents, so you can imagine as I add and delete them it is a real pain in the rump to have to go to each macro and change the names over and over again.

In advance thanks a lot!!!

 

[Nikita6003]

Sure:

First step: EITHER add a worksheet, name this NameList, then enter the list of names there, & name the first cell of the range StartNames OR add an array to your code.

1st solution:
Add This modified copy of your function - its generic & takes the name as parameter

Sub ChangeCellColor(p_sName As String)
    Dim counter As Integer
    Dim l_wksSheetToChange As WorkSheet

    'This sets the worksheet to the one where you want to change the colour
    'The (1) refers to the FIRST sheet in the workbook
    'Please adapt as needed
    Set l_wksSheetToChange = ThisWorkbook.Sheets(1)

    For counter = 1 To 20
        On Error GoTo MyErrorHandler
        'Changed actual name to the generic p_sName: the variable passe to the Sub
        Cells.Find(What:=p_sName , After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=True).EntireRow.Select
           Selection.Interior.ColorIndex = 3
           ActiveCell.Offset(1, 0).Range("A1").Select
    Next counter
      MsgBox ("Done")
Exit Sub
MyErrorHandler:
    If Err.Number = 91 Then
      MsgBox ("Done")
    End If
End Sub

'Now Write your main Sub:
Sub ChangeColoursForNamesInList()
    Dim l_wksNames as WorkSheet
    Dim l_lRow As Long
    Dim l_iName As Integer
    Dim l_sNamesToLoop() As String

    'Set worksheet with names
    Set l_wksNames = ThisWorkBook.Sheets("NameList")
    'Init array of names
    Redim l_sNamesToLoop(0)

    'Read the list of names
    Do Until l_wksNames.Range("StartNames").OffSet(l_lRow, 0) = ""
        l_sNamesToLoop(Ubound(l_sNamesToLoop)) = l_wksNames.Range("StartNames").OffSet(l_lRow, 0)
        'Add a new empty element to the array
        Redim Preserve l_sNamesToLoop(Ubound(l_sNamesToLoop) + 1)
        l_lRow = l_lRow + 1
    Loop
    'Take away last - empty - element of Names listy
    Redim Preserve l_sNamesToLoop(Ubound(l_sNamesToLoop) - 1)

    'Now Loop thru' the list of names & call your sub:
    For l_iName = 0 To Ubound(l_sNamesToLoop)
        Call ChangeCellColor(l_sNamesToLoop(l_iName))
    Next l_iName

End Sub

Solution 2 is similar but sets the list of names in code - this is less easy to maintain than the list in the worksheet:
Add This modified copy of your function - it's generic & takes the name as parameter
Sub ChangeCellColor(p_sName As String)
Dim counter As Integer
Dim l_wksSheetToChange As WorkSheet

'This sets the worksheet to the one where you want to change the colour
'The (1) refers to the FIRST sheet in the workbook
'Please adapt as needed
Set l_wksSheetToChange = ThisWorkbook.Sheets(1)

For counter = 1 To 20
On Error GoTo MyErrorHandler
'Changed actual name to the generic p_sName: the variable passe to the Sub
Cells.Find(What:=p_sName , After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True).EntireRow.Select
Selection.Interior.ColorIndex = 3
ActiveCell.Offset(1, 0).Range("A1&quot.Select
Next counter
MsgBox ("Done&quot
Exit Sub
MyErrorHandler:
If Err.Number = 91 Then
MsgBox ("Done&quot
End If
End Sub

'Now Write your main Sub:
Sub ChangeColoursForNamesInList()
Dim l_lRow As Long
Dim l_iName As Integer
Dim l_vNamesToLoop As Variant

'Set array with names
l_vNamesToLoop = Array("John Doe","Jane Doe","John Smith&quot

'Now Loop thru' the list of names & call your sub:
For l_iName = 0 To Ubound(l_vNamesToLoop)
Call ChangeCellColor(CStr(l_vNamesToLoop(l_iName)))
Next l_iName

End Sub
[/code]

HTH

Cheers
Nikki

 

[maerts]

Thanks Nikita6003, someone found a shorter way but if it does not work for me I will try yours