Column with same characters as Col1 to be in color

[Dalia123]

I am trying to make something like a small kids dictionary file in my native language.

One column has a specific word 'example PLAY' the next column has different forms of the same characters. say 'PLAY ground'. I need the second column which has the word 'PLAY ground' to color the characters (i.e. not the whole word as a unit. but individual characters included in col1 word, and included in the second column.

example in the below (i.e. the caps in the second column should be in color say red)

col1 col2
PLAY PLAYground
PLAY PLAY boY

can u help me?
[/img]

 

[Anthony47]

Hum, interesting.
You will have a list of Words (1 or more words per cell?) in col.1 and list of Phrases in col.2; right?

Would you like having the color effect on the "currently selected row" or on all the Phrases in col.2?

Let me know, bye.

 

[Dalia123]

I want the color effect only in column 2 in the same raw.

example

col1 col2
row1 GIRL fGsRR
row2 TWO grTiO

 

[yee388]

To the extent of my knowledge, it is not possible to automatically change the color of a portion of a cell.

 

[pgc01]

Hi Dalia123

This is an example of a simple code that does what you want.

In this example I considered that the words are in column A and the sentences that includes the word (even as part of another word like in PLAYground) are in column B.

The words will be coloured in red in column B.

Hope this gets you started
PGC

Option Compare Text

Sub ColourHighlightText()
Dim rR As Range, rC As Range, vPos

Set rR = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each rC In rR
    vPos = InStr(rC.Offset(0, 1), rC)
    If vPos > 0 Then
        rC.Offset(0, 1).Characters(vPos, Len(rC)).Font.ColorIndex = 3
    End If
Next
End Sub

 

[erik.van.geit]

Hi,

you can have different fonts, colors, sizes, ... in one cell
type abc123abc in a cell
select "123"
do some formatedits
enter


this code will check all items in column A and find them anywhere on the sheet (except column A of course)
to have the desired effect you can
OR
give all items another fontcolor
OR
enable the line
.ColorIndex = 3 (disable the other)

Option Explicit

Sub color_words_according_to_list()
'Erik Van Geit
'060905
'column A has items to find in MatchRng
'all occurencies of those items are colored
'same fontcolor as items

'EXAMPLE
'LIST       MatchRng (may be more columns)
'PLAY       PLAY this game
'SCHOOL     please don't read
'BOY        are you going to school or not
'GIRL       who's this little boy
'           are you a girl
'           have a PLAY with this
'           who's PLAYing in school
'           you can find here boys and girls
'RESULT
'"play" font = red
'"school" font = green
'all occurencies of "play" will be red (see uppercase)
'different items in same cells of MatchRng will be colored
'who's PLAY(red)ing in SCHOOL(green) ?

Dim CheckList As Range
Dim CheckCell As Range
Dim CheckText As String
Dim MatchRng As Range   'to find in this range
Dim MatchCell As Range
Dim LR As Long          'Last Row
Dim LC As Integer       'Last Column
Dim FA As String        'First Adress

LR = Cells(Rows.Count, 1).End(xlUp).Row
Set CheckList = Range("A1:A" & LR)
LR = Cells.Find("*", [A1], xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row
LC = Cells.Find("*", [A1], xlFormulas, xlPart, xlByColumns, xlPrevious, False, False).Column
Set MatchRng = Range(Range("B1"), Cells(LR, LC))


    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    End With

    With MatchRng
        For Each CheckCell In CheckList
        CheckText = CheckCell.Value
            If CheckText <> "" Then
            Set MatchCell = .Find(CheckText, .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False, False)
                If Not MatchCell Is Nothing Then
                FA = MatchCell.Address
                    Do
                    Call color_word(MatchCell, CheckText, CheckCell.Font.ColorIndex)
                    Set MatchCell = .FindNext(MatchCell)
                    Loop While Not MatchCell Is Nothing And MatchCell.Address <> FA
                End If
            End If
        Next CheckCell
    End With

    With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub color_word(C As Range, txt As String, col As Integer)
    With C.Characters(InStr(1, LCase(C), LCase(txt)), Len(txt)).Font
        'color according to fontcolor of item to find
        .ColorIndex = col
        'or a "fixed" color if you want
        '.ColorIndex = 3
        .Bold = True
    End With
End Sub

  A      B                                
1 PLAY   play this game                   
2 SCHOOL please don't read                
3 BOY    are you going to school or not ? 
4 GIRL   who's this little boy            
5        are you a girl                   
6        have a play with this            
7        who's playing in school ?        
8        you can find here boys and girls 

Blad1
[Table-It] version 05 by Erik Van Geit

perhaps a bit more than what you asked

kind regards,
Erik

EDIT: added "Ad Integer" on line
Sub color_word(C As Range, txt As String, col As Integer)

 

[Dalia123]

worked only in special cases as in the examples below
ABC ABC ===>only correct row
ABC ABCd===>only correct row
ABC afbfcf (did not work in this row
ABCD abc (did not work)

 

[Dalia123]

Erik,

Your code can help me. But it's not exactly what I want.

I need it to search the chracters in col1/rowX and highlight similar characters (not words) in col2/rowX

example
Col1 Col2
ABC kAfBsau
DEF abcEu

 

[erik.van.geit]

Erik,

Your code can help me. But it's not exactly what I want.

I need it to search the chracters in col1/rowX and highlight similar characters (not words) in col2/rowX

example
Col1 Col2
ABC kAfBsau
DEF abcEu

my code is not helpful for you, but we will produce something else ...
anyway you can see the "characters"-trick and play with it

 

[erik.van.geit]

try this

Option Explicit

Sub test()
'Erik Van Geit
'060905

Dim LR As Long
Dim i As Long
Dim j As Integer
Dim CheckText As String
LR = Cells(Rows.Count, 1).End(xlUp).Row


    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    End With
    
    For i = 1 To LR
    CheckText = LCase(Cells(i, 1))
        With Cells(i, 2)
            For j = 1 To Len(.Value)
            If InStr(1, CheckText, LCase(Mid(.Value, j, 1))) > 0 Then Call color_word(Cells(i, 2), j)
            Next j
        End With
    Next i
    
    With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub color_word(C As Range, j As Integer)
    With C.Characters(j, 1).Font
        .ColorIndex = 3
        '.Bold = True
    End With
End Sub

EDIT: changed macroname to "test"