Finding a specific text string within a cell

[jmfox]

Hi everyone,

I am wondering whether you could help me.We use a spreadsheet to track all of the events we organise.

In one of the cells per row is the list of workers, each of these are then colour coded based on different criteria (I know this is not the most effective way of doing so).

I am lookling at a way of searching for specific names (stored in a string) and them chaning them to black. For example, when adding another name to the sheet I have managed to do this using the following code:

Range("L" & ActiveCell.Row).Characters(InStr(1, Range("L" & ActiveCell.Row), AmbContacts), Len(AmbContacts)).Font.ColorIndex = vbBlack

This does work OK however if there are multiple colours before the string (it changes some of these, it's a bit difficult to explain so should make sense with the example below)

Worker 1, Worker 2, Worker 3 (This works fine with just one blue colour before the additon of worker 3)
Worker 1, Worker 2, Worker 3 (If 3 colours are used, worker 1 also becomes blue)For the life of me I cannot understand why this occurs. If it is of any use, the string "AmbContacts" will always be at the end of the cell.

I really appreciate your advice in advance.

Jack

[mdmackillop]

Can you post Sample workbook. Use Manage Attachments in the Go Advanced reply section

[jmfox]

Hi,

I have uploaded the relevant section of code. The way the spreadsheet works is the user clicks anywhere on the row of the relevant record and then clicks Add worker.

After inputing the name this needs to be added to the relevant cell on the spreadsheet in black but it needs to retain the exact formatting of the cell contents before.

Thanks for looking.

[mdmackillop]

Option Explicit

Sub Button1_Click()
Dim c As String, txt As String, arr(), cel As Range
Dim i As Long
Dim ambContacts 'Name of worker to be added to column
ambContacts = InputBox("Please enter the name of the worker")

If Range("L" & ActiveCell.Row).Value = "" Then
'MsgBox "Cell is Empty"
Range("L" & ActiveCell.Row).Value = ambContacts
Range("L" & ActiveCell.Row).Font.ColorIndex = 1
Else
'MsgBox "Cell is NOT Empty"
Set cel = Range("L" & ActiveCell.Row)

ReDim arr(Len(cel.Value) + Len(ambContacts) + 2)
For i = 1 To Len(cel)
arr(i) = cel.Characters(i, 1).Font.ColorIndex
Next
arr(i + 1) = arr(i)

Range("L" & ActiveCell.Row).Value = Range("L" & ActiveCell.Row).Value & ", " & ambContacts
For i = 1 To UBound(arr)
Range("L" & ActiveCell.Row).Characters(i, 1).Font.ColorIndex = arr(i)
Next
End If

End Sub