Need Help Highliting Some String in Cell and Columns With Macro!

[icemail]

Hello i create macro by my own. There are no error but not working well.
Macro work on B,C,E columns. I fill B and E colums manually. Macro fill C column automatically.
And highlight B,C,E columns and some string in cell.

Explain Macro:
- Macro checking "#" character for coloring. If string dont have "#" its mean excel regular black color.
- The second character next to "#" represents which color it will be. Example #r = red, #b = blue etc.(color list on the sheet if needed)
- Macro start with B2 cell and split by space to in array(by "#"). In array finding string position and colorization. Then go E2 and looking "#" character if find colorize string and paste to string c2.

But somehow colorizatin is get confused and cell not colorized well. I shared my excel.
I'm waiting for your help.
PS:And i wonder if my code can be update more programatically or more profesional way.
Thank you.

[Paul_Hossler]

Other ways to do it, but this seems like the most straight forward



Option Explicit


Sub Highlight()
Dim ws As Worksheet
Dim r As Range


'Save Workbook
If MsgBox("Do you want to save changes to Excel before running macros?", vbQuestion + vbYesNo + vbDefaultButton2, "Message Box Title") = vbYes Then
ActiveWorkbook.Save
End If


'Declare Range
Set ws = ThisWorkbook.Sheets("Reality")

'col B
Set r = ws.Cells(2, 2)
Set r = Range(r, r.End(xlDown))
Call ColorColumn(r, 0)

'col E, put results 2 col to left, i.e. C
Set r = ws.Cells(2, 5)
Set r = Range(r, r.End(xlDown))
Call ColorColumn(r, -2)
End Sub




'========================================================================== =============
Sub ColorColumn(r As Range, Optional ColumnOffset As Long = 0)
Const SpecialCharacters As String = "!@$%^&*(){[]}?,_"

Dim s As String
Dim r1 As Range
Dim arySplit As Variant
Dim aryPos() As Long, aryColor() As Long
Dim i As Long

For Each r1 In r.Columns(1).Cells
s = r1.Value

'Clear unwanted characters from array element
For i = 1 To Len(SpecialCharacters)
s = Replace(s, Mid(SpecialCharacters, i, 1), "")
Next i

'remove double spaces and comma
s = Replace(s, " ", " ")

'if no # leave alone
If InStr(s, "#") = 0 Then
r1.Offset(0, ColumnOffset).Value = r1.Value

Else
'split on space
arySplit = Split(s, " ")

'make same size as split array
ReDim aryPos(LBound(arySplit) To UBound(arySplit))
ReDim aryColor(LBound(arySplit) To UBound(arySplit))

'for each piece, if starts with #, get second char and save color
For i = LBound(arySplit) To UBound(arySplit)
If Left$(arySplit(i), 1) = "#" Then
Select Case UCase(Mid(arySplit(i), 2, 1))
Case "R"
aryColor(i) = RGB(255, 0, 0)
Case "I"
aryColor(i) = RGB(0, 191, 255)
Case "V"
aryColor(i) = RGB(255, 0, 255)
Case "B"
aryColor(i) = RGB(0, 0, 255)
Case "O"
aryColor(i) = RGB(255, 165, 0)
Case "N"
aryColor(i) = RGB(128, 0, 0)
Case "S"
aryColor(i) = RGB(46, 139, 87)
Case "T"
aryColor(i) = RGB(255, 99, 71)
Case "C"
aryColor(i) = RGB(100, 149, 237)
Case "P"
aryColor(i) = RGB(128, 0, 128)
Case "L"
aryColor(i) = RGB(50, 205, 50)
Case "A"
aryColor(i) = RGB(0, 255, 255)
Case Else
aryColor(i) = 0
End Select

'save piece after # and color
arySplit(i) = Right(arySplit(i), Len(arySplit(i)) - 2)
End If
Next i

'build aryPos
'arySplit (0) (1) (2) (3)(4)
'AAAA BBBB CC DDD EEE
'AryColor X1 X2 X3 X4 X5
' 1 2
' 12345678901234567890
' AAAA BBBB CC DDD DDD
'AryPos 1 6 11 14 18

aryPos(0) = 1
For i = LBound(arySplit) + 1 To UBound(arySplit)
aryPos(i) = aryPos(i - 1) + Len(arySplit(i - 1)) + 1
Next i

'build string
r1.Offset(0, ColumnOffset).Value = Join(arySplit, " ")

For i = LBound(arySplit) To UBound(arySplit)
If aryColor(i) > 0 Then
r1.Offset(0, ColumnOffset).Characters(Start:=aryPos(i), Length:=Len(arySplit(i))).Font.Color = aryColor(i)
r1.Offset(0, ColumnOffset).Characters(Start:=aryPos(i), Length:=Len(arySplit(i))).Font.Bold = True
End If
Next i
End If
Next


End Sub

[icemail]

Thank you Paul your code working well and educational.