Want this code to work if any part of answer appears (Joe, Analyst, not just Analyst)

[Kusaywa]

I have a formula that pulls from a list of employees via their ID Number.
Employees that are Analysts have Analyst next to their name (Joe Jones, Analyst).
This code only works if the answer is "Analyst"
How can I get it to work with any employee that has Analyst in their Name?
This way I don't have to change the code for every employee.
Thanks

Private Sub Worksheet_Change(ByVal Target As Range)
Set MyPlage = Range("A2:D4800")
      
    For Each cell In MyPlage
      ActiveSheet.Unprotect ("peteamy")
        Select Case cell.Value
          
         Case Is = "Analyst"
            cell.EntireRow.Font.ColorIndex = 3
          ActiveSheet.Protect ("peteamy")
        End Select
End Sub

 

[L. Howard]

Try the Worksheet_Change code like this... UNTESTED on my end.

Howard

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyPlage As Range, c As Range
Dim rw As Long
Dim Answ As String
Dim Sht As Worksheet
Dim MyPath As String
Dim MyFileName As String

Set MyPlage = Range("A2:D4800")
      
 ActiveSheet.Unprotect ("peteamy")

    For Each cell In MyPlage

      If InStr(c, "Analyst") > 0 Then
        c.EntireRow.Font.ColorIndex = 3
      End If
    
    Next
      
ActiveSheet.Protect ("peteamy")


rw = Target.Row
     If Range("B" & rw).Value <> "" Then
        ActiveSheet.Unprotect ("peteamy")
        Range("D" & rw).Locked = False
        ActiveSheet.Protect ("peteamy")
        'Remove locked property if B3's value is anything else or is deleted.
     Else
        ActiveSheet.Unprotect ("peteamy")
        Range("D" & rw).Locked = True
        'Optional, reprotect sheet
        ActiveSheet.Protect ("peteamy")
     End If

Application.ScreenUpdating = False
Answ = MsgBox("Do you wish to confirm entry of this data?", vbOKCancel, "Confirm Change")
  If Answ <> vbOK Then
    Application.EnableEvents = False
    Target.ClearContents 'clear contents if cancel is pressed
    Application.EnableEvents = True
  Exit Sub
  End If
  
ActiveSheet.Unprotect "peteamy"
Target.Locked = True
ActiveSheet.Protect Password:="peteamy", DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
 
 
  If Target.Address = "$D$4800" Then
  
    
    Application.DisplayAlerts = False
    MyPath = ThisWorkbook.Path
    MyFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & (" ") & Format(Now, "dd-mm-yyyy hh-mm")
    
    If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
    If Not Right(MyFileName, 4) = ".xlsx" Then MyFileName = MyFileName & ".xlsx"
    
    ActiveSheet.Copy
    
    With ActiveWorkbook
    
        .SaveAs Filename:= _
            MyPath & MyFileName, _
            CreateBackup:=False
            
        .Close False
        
        Application.DisplayAlerts = True
        
        End With
  
  ActiveWorkbook.Unprotect "peteamy"
  Application.ScreenUpdating = False
  Sheets("Sheet2").Visible = True
    'Replace "Sheet1" with the name of the sheet to be copied.
    ActiveWorkbook.Sheets("Sheet2").Copy _
       after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
       Sheets("Sheet2").Visible = xlSheetVeryHidden
       
       
       Application.DisplayAlerts = False
On Error Resume Next
ActiveSheet.Previous.Previous.Delete
ActiveWorkbook.Protect "peteamy"
   End If
   
   On Error Resume Next
    Application.EnableEvents = False
    If Not Target.Cells.CountLarge > 1 Then
        
        If Not Intersect(Target, Columns(4)) Is Nothing Then
            Target.Offset(1, -2).Select
        End If
    End If
Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
       
End Sub

 

[Kusaywa]

Duh!
Your original change worked!!!
I never seen the ' before ActiveSheet.Protect/Unprotect.
Sorry for the trouble.
THANKS

 

[Kusaywa]

L. Howard, you've been very helpful... Thanks again.
One thing I noticed with this code is if you put someone in that is an "Analyst" and then cancel the input...
When you change it to a non "Analyst" the row remains red (3).
It doesn't revert back to black.
Is there a way to fix this?
Thanks

 

[L. Howard]

I'm a bit unsure what you are doing on the sheet/s with the string "Analyst", but it looks like... if the string "Analyst" is there, the Font = RED. If it is not there the Font = Automatic.

Does that seem to be the scenario?

Howard

 

[Kusaywa]

I'm trying to make my sheet as "idiot proof" as possible.
What happens is the user puts his employer number in D*.
This, in turn, generates their name in C*.
This is taken from a separate database.
So anyone in the company who is an "Analyst", their entries will appear in red if their name says for example " Joe Jones, Analyst".
This way with promotions and demotions or other positions (which I can assign a different color) I just have to update the employer database.
What I found was happening is if someone puts in an ID of an Analyst, and cancels, then changes it to theirs, it stays red. It doesn't do it the other way around... Oddly?

 

[Kusaywa]

Solved it!
Got to thinking when typing the above.
I added the following, and all is good!
Once again, Thanks!

If InStr(c, "") > 0 Then
        c.EntireRow.Font.ColorIndex = 1

 

[L. Howard]

You could try you For Each statement like this.

Howard

    For Each c In MyPlage
      If InStr(c, "Analyst") > 0 Then
        c.EntireRow.Font.ColorIndex = 3
       ElseIf InStr(c, "Analyst") = 0 Then
        c.EntireRow.Font.ColorIndex = xlAutomatic
      End If
    
    Next