Macro to detect and change color of text and to change color of text after a symbol

[MarinheiroQ]

Hello,

I'm looking for a macro where I can provide the range of cells in a sheet for the macro to look through and change the color of certain words. One more feauture I need is that the macro detects a symbol (for example $) and changes the color of the text after that symbol and then erases the symbol. I need it to work with my already existing macro which ill leave below. Im using these macros with a button. Thank you !

Sub Macro1()
Range("H1", "H9999").Clear
Range("I1", "I9999").Clear
Range("J1", "J9999").Clear
Range("K1", "K9999").Clear
Range("L1", "L9999").Clear
Range("M1", "M9999").Clear
Range("N1", "N9999").Clear
Range("O1", "O9999").Clear
Range("P1", "P9999").Clear
Range("Q1", "Q9999").Clear
Range("R1", "R9999").Clear
Range("S1", "S9999").Clear
Range("T1", "T9999").Clear
Range("U1", "U9999").Clear
Range("V1", "V9999").Clear
Range("W1", "W9999").Clear
Range("V1", "V9999").Clear
Range("X1", "X9999").Clear
Range("E5", "E1000").Font.Size = 9
Range("F5", "F1000").Font.Size = 9
Range("G5", "G1000").Font.Size = 9
Range("E5", "E1000").Font.Name = "cambria"
Range("F5", "F1000").Font.Name = "cambria"
Range("G5", "G1000").Font.Name = "cambria"
Range("E5", "E1000").Borders.LineStyle = xlContinuous
Range("F5", "F1000").Borders.LineStyle = xlContinuous
Range("G5", "G1000").Borders.LineStyle = xlContinuous
Range("E5", "E1000").RowHeight = 15
Range("F5", "F1000").RowHeight = 15
Range("G5", "G1000").RowHeight = 15
Range("D5").CurrentRegion.Sort key1:=Range("D5"), ORDER1:=xlAscending, Header:=xlNo
On Error Resume Next
Columns.Range("G5", "G1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns.Range("F5", "F1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

 

[Zot]

In my example, I put the sentence below in any cell. Then select the cell and run the sub test1 or test2.

The test1 will find word and and color it red.
The test 2 will find word and and color the rest of text after it. So, it can be a word or a symbol

Find a word and color it or color the rest of word after it

Sub test1()

Call ColorMe(Selection, "and")

End Sub

Sub test2()

Call ColorMe(Selection, "and", True)

End Sub

Sub ColorMe(rng As Range, char As String, Optional ToEnd As Boolean = False)

With Selection
    i = WorksheetFunction.Find(char, .Value)
    If Not ToEnd Then
        .Characters(i, Len(char)).Font.Color = vbRed
    Else
        .Characters(i + Len(char), Len(rng)).Font.Color = vbBlue
    End If
End With

End Sub

 

[MarinheiroQ]

In my example, I put the sentence below in any cell. Then select the cell and run the sub test1 or test2.

The test1 will find word and and color it red.
The test 2 will find word and and color the rest of text after it. So, it can be a word or a symbol

Find a word and color it or color the rest of word after it

Sub test1()

Call ColorMe(Selection, "and")

End Sub

Sub test2()

Call ColorMe(Selection, "and", True)

End Sub

Sub ColorMe(rng As Range, char As String, Optional ToEnd As Boolean = False)

With Selection
    i = WorksheetFunction.Find(char, .Value)
    If Not ToEnd Then
        .Characters(i, Len(char)).Font.Color = vbRed
    Else
        .Characters(i + Len(char), Len(rng)).Font.Color = vbBlue
    End If
End With

End Sub

Thank you for your help ! that works cell by cell, what if i wanted to do it on a selection of cells ? I was trying to make it so that I could go trough lots of cells only running the macro one time but it won't let me use more than one selected cell.

I needed it to work with the selection of cells I made both for the "finding a word and color it" and "finding a symbol and color everything after it".

Wanted something like this that worked

Sub ColorMe(rng As Range, char As String, Optional ToEnd As Boolean = False)

Range("G5", "G1000").Select

With Selection

i = WorksheetFunction.Find(char, .Value)
If Not ToEnd Then
.Characters(i, Len(char)).Font.Color = vbRed
Else
.Characters(i + Len(char), Len(rng)).Font.Color = vbBlue
End If
End With

End Sub

 

[Zot]

Then try this. I change to Search instead of Find because Find is Case sensitive, unless you prefer it to

Sub test1()

Dim i As Long
Dim char As String
Dim cell As Range, rng As Range
Dim ToEnd As Boolean

' Set any range here
Set rng = Range("G5", "G1000")
' Set char or symbol here
char = "text/symbol"
' Set to color until end or just single word/char here. True = Color all text after the word/symbol. False = Highlight word/symbol
ToEnd = False

For Each cell In rng
    If Not IsEmpty(cell) Then
        i = WorksheetFunction.Search(char, cell.Value)
        If Not ToEnd Then
            cell.Characters(i, Len(char)).Font.Color = vbRed
        Else
            cell.Characters(i + Len(char), Len(cell.Value)).Font.Color = vbBlue
        End If
    End If
Next

End Sub

 

[MarinheiroQ]

Then try this. I change to Search instead of Find because Find is Case sensitive, unless you prefer it to

Sub test1()

Dim i As Long
Dim char As String
Dim cell As Range, rng As Range
Dim ToEnd As Boolean

' Set any range here
Set rng = Range("G5", "G1000")
' Set char or symbol here
char = "text/symbol"
' Set to color until end or just single word/char here. True = Color all text after the word/symbol. False = Highlight word/symbol
ToEnd = False

For Each cell In rng
    If Not IsEmpty(cell) Then
        i = WorksheetFunction.Search(char, cell.Value)
        If Not ToEnd Then
            cell.Characters(i, Len(char)).Font.Color = vbRed
        Else
            cell.Characters(i + Len(char), Len(cell.Value)).Font.Color = vbBlue
        End If
    End If
Next

End Sub

I would prefer it to be case sensitive, with what you sent me this was what I came up with, really only needed this to work with a selection of cells instead of just one, I wanted it to scan trough the selection of cells and color the multiple words I wanted red and the multiple sentences after the symbol > blue but all of this in one GO. Can you explain how can i use the one with Find but with a selection of cells, where it will search for the word and color each one until the end and the phrases after > too ?

Sub Principal()

Call Modulo1
Call Modulo2
Call Modulo3
Call Modulo4

End Sub

Sub Modulo1()
Range("H1", "H9999").Clear
Range("I1", "I9999").Clear
Range("J1", "J9999").Clear
Range("K1", "K9999").Clear
Range("L1", "L9999").Clear
Range("M1", "M9999").Clear
Range("N1", "N9999").Clear
Range("O1", "O9999").Clear
Range("P1", "P9999").Clear
Range("Q1", "Q9999").Clear
Range("R1", "R9999").Clear
Range("S1", "S9999").Clear
Range("T1", "T9999").Clear
Range("U1", "U9999").Clear
Range("V1", "V9999").Clear
Range("W1", "W9999").Clear
Range("V1", "V9999").Clear
Range("X1", "X9999").Clear
Range("E5", "E1000").Font.Size = 9
Range("F5", "F1000").Font.Size = 9
Range("G5", "G1000").Font.Size = 9
Range("E5", "E1000").Font.Name = "cambria"
Range("F5", "F1000").Font.Name = "cambria"
Range("G5", "G1000").Font.Name = "cambria"
Range("E5", "E1000").Borders.LineStyle = xlContinuous
Range("F5", "F1000").Borders.LineStyle = xlContinuous
Range("G5", "G1000").Borders.LineStyle = xlContinuous
Range("E5", "E1000").RowHeight = 15
Range("F5", "F1000").RowHeight = 15
Range("G5", "G1000").RowHeight = 15
Range("D5").CurrentRegion.Sort key1:=Range("D5"), ORDER1:=xlAscending, Header:=xlNo
On Error Resume Next
Columns.Range("G5", "G1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns.Range("F5", "F1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Sub Modulo2()

Call Modulocor(Selection, "Aguarda")

End Sub

Sub Modulo3()

Call Modulocor(Selection, "resolução")

End Sub

Sub Modulo4()

Call Modulocor(Selection, ">", True)

End Sub

Sub Modulocor(rng As Range, char As String, Optional ToEnd As Boolean = False)

With Selection

    i = WorksheetFunction.Find(char, .Value)
    If Not ToEnd Then
        .Characters(i, Len(char)).Font.Color = vbRed
    Else
        .Characters(i + Len(char), Len(rng)).Font.Color = vbBlue
    End If
End With

End Sub

 

[Zot]

Check if this fulfill your requirement. If you have two Aguarda word in a sentence, it will color the first one only with this code.
You select as many rows and column first and then run Modulo1 or Modulo2

Sub Modulo1()
Call Modulocor(Selection, ">", True)
End Sub

Sub Modulo2()
Call Modulocor(Selection, "Aguarda")
End Sub


Sub Modulocor(rng As Range, char As String, Optional ToEnd As Boolean = False)

Dim cell As Range

On Error Resume Next
For Each cell In rng.SpecialCells(xlCellTypeConstants)
    i = 0
    i = WorksheetFunction.Find(char, cell)
    If i > 0 Then
        If Not ToEnd Then
            cell.Characters(i, Len(char)).Font.Color = vbRed
        Else
            cell.Characters(i + Len(char), Len(cell)).Font.Color = vbBlue
        End If
    End If
Next
On Error GoTo 0

End Sub

 

[MarinheiroQ]

I'm almost getting it to work perfectly, the last thing I need is a way of getting my vba to count the symbols in a sentence/cell and consider only the last symbol for my second function:

What im getting:
i have a sentence | with multiple | of the | symbols and this is the end| result right now

What i want:
i have a sentence | with multiple | of the | symbols and this is the end | result i need

I want to find the last "|" and use the ModB after that last "|"

Don't know if there is something like (selection, last"|",True)

VBA:

Sub ModA()
Call ModB(Selection, "|", True)
End Sub

Sub ModB(rng As Range, char As String, Optional ToEnd As Boolean = False)

Dim cell As Range

On Error Resume Next
For Each cell In rng.SpecialCells(xlCellTypeConstants)
i = 0
i = WorksheetFunction.Find(char, cell)
If i > 0 Then
If Not ToEnd Then
cell.Characters(i + Len(char), Len(cell)).Font.Color = vbBlue
cell.Characters(i + Len(char), Len(cell)).Font.Italic = True
Else
cell.Characters(i + Len(char), Len(cell)).Font.Color = vbBlue
cell.Characters(i + Len(char), Len(cell)).Font.Italic = True
End If
End If
Next
On Error GoTo 0

End Sub

 

[Zot]

This has been quite sometimes and I also has been so busy and not login in for quite long time

Instead of using Find, I'll use Instr and InstrRev. The InstrRev can search from back. Below is my revised code

Sub ModB(rng As Range, char As String, Optional ToEnd As Boolean = False, Optional Reverse As Boolean = False)

Dim cell As Range

On Error Resume Next
For Each cell In rng.SpecialCells(xlCellTypeConstants)
    i = 0
    If Reverse Then
        i = InStrRev(cell, char)
    Else
        i = InStr(cell, char)
    End If
    i = InStrRev(cell, char)
    If i > 0 Then
        If Not ToEnd Then
            cell.Characters(i, Len(char)).Font.Color = vbRed
        Else
            cell.Characters(i + Len(char), Len(cell)).Font.Color = vbBlue
        End If
    End If
Next
On Error GoTo 0

End Sub

I added option to search in reverse order. Therefore, the usage is like this example (your string in range B3):

Sub Test()

Call ModB(Range("B3"), "|", True, True)

End Sub

 

[MarinheiroQ]

Its working great, I haven't logged in for a while too but I'm in need of some help with the macro so I had to .

I will put here two more questions here, you have been a great help!

First:

Turning the font color blue (RGB(0, 112, 192)) on that last cell when there is neither a "|" nor a "Aguarda resolução".

Second:

I'm doing some experiments with Outlook module. I got it to the point of exporting the table to a mail but I have two problems when I do it. First problem is that it won't export the color differences in sentences, it only exports colors when the whole text in the cell is in that color. The second and less destressing is that it exports the table but fails to fill the last line of the table. I will leave examples below and all my code. Thank you for all your help again, I have already turned a task that took me 20 minutes to do into something that takes only 5!

So, exporting this from excel:

Turns into this in my mail (Missing colors and last row has no line below):

This is my code (I will leave the function im using for HTML exporting too):

Function:

[/B]
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
[B]

My code:

[/B]
Sub GERAL()
Call ModuloA
Call ModuloB
Call ModuloC1
Call ModuloC2
Call ModuloC3
Call ModuloC4
Call ModuloC5
Call ModuloC6
Application.Wait (Now + TimeValue("0:00:2"))
Call Mail
End Sub



Sub ModuloA()
Range("H5", "H9999").Clear
Range("I5", "I9999").Clear
Range("J5", "J9999").Clear
Range("K5", "K9999").Clear
Range("L5", "L9999").Clear
Range("M5", "M9999").Clear
Range("N5", "N9999").Clear
Range("O5", "O9999").Clear
Range("P5", "P9999").Clear
Range("Q5", "Q9999").Clear
Range("R5", "R9999").Clear
Range("S5", "S9999").Clear
Range("T5", "T9999").Clear
Range("U5", "U9999").Clear
Range("V5", "V9999").Clear
Range("W5", "W9999").Clear
Range("V5", "V9999").Clear
Range("X5", "X9999").Clear
Range("E5", "E1000").Font.Size = 9
Range("F5", "F1000").Font.Size = 9
Range("G5", "G1000").Font.Size = 9
Range("E5", "E1000").Font.Name = "cambria"
Range("F5", "F1000").Font.Name = "cambria"
Range("G5", "G1000").Font.Name = "cambria"
Range("E5", "E1000").Borders.LineStyle = xlContinuous
Range("F5", "F1000").Borders.LineStyle = xlContinuous
Range("G5", "G1000").Borders.LineStyle = xlContinuous
Range("E5", "E1000").RowHeight = 15
Range("F5", "F1000").RowHeight = 15
Range("G5", "G1000").RowHeight = 15
Range("D5").CurrentRegion.Sort key1:=Range("D5"), ORDER1:=xlAscending, Header:=xlNo
On Error Resume Next
Columns.Range("G5", "G1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns.Range("F5", "F1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete



End Sub




Sub ModuloB()
Call Modulocor1(Range("G6", "G1000"), "|", True, True)
End Sub



Sub ModuloC1()
Call Modulocor2(Selection, "Aguarda resolução")
End Sub



Sub ModuloC2()
Call Modulocor2(Selection, "Aguarda resolucao")
End Sub



Sub ModuloC3()
Call Modulocor2(Selection, "Aguarda Resolução")
End Sub



Sub ModuloC4()
Call Modulocor2(Selection, "Aguarda Resolucao")
End Sub



Sub ModuloC5()
Call Modulocor2(Selection, "AGUARDA RESOLUCAO")
End Sub



Sub ModuloC6()
Call Modulocor2(Selection, "AGUARDA RESOLUÇÃO")
End Sub






Sub Modulocor1(rng As Range, char As String, Optional ToEnd As Boolean = False, Optional Reverse As Boolean = False)

Dim cell As Range

On Error Resume Next
For Each cell In rng.SpecialCells(xlCellTypeConstants)
    i = 0
    If Reverse Then
        i = InStrRev(cell, char)
    Else
        i = InStr(cell, char)
    End If
    i = InStrRev(cell, char)
    If i > 0 Then
        If Not ToEnd Then
            cell.Characters(i, Len(char)).Font.Color = vbRed
        Else
            cell.Characters(i + Len(char), Len(cell)).Font.Color = RGB(0, 112, 192)
            cell.Characters(i + Len(char), Len(cell)).Font.Italic = True
        End If
    End If
Next
On Error GoTo 0

End Sub



Sub Modulocor2(rng As Range, char As String, Optional ToEnd As Boolean = False)



Dim cell As Range



On Error Resume Next
For Each cell In rng.SpecialCells(xlCellTypeConstants)
i = 0
i = WorksheetFunction.Find(char, cell)
If i > 0 Then
If Not ToEnd Then
cell.Characters(i, Len(char)).Font.Color = vbRed
cell.Characters(i, Len(char)).Font.Italic = True
Else
cell.Characters(i, Len(char)).Font.Color = vbRed
cell.Characters(i, Len(char)).Font.Italic = True
End If
End If
Next
On Error GoTo 0



End Sub

Sub Mail()

Dim OutApp As Object
Dim OutMail As Object
Dim rg1 As Range, rg2 As Range              
Dim str1 As String, str2 As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Set rg1 = Sheets("Sheet1").Range(Cells(6, 5), Cells(1000, 7))


str1 = "<BODY style = font-size:12pt;font-family:Cambria>" & _
"Seguem os erros, <p> So copiar e colar.<br>"

str2 = "<br>Folhas Marinheiro™,<br>"

On Error Resume Next
    With OutMail
    .To = ""
    .CC = ""
    .Subject = "Exporte de Erros"
    .Display
    .HTMLBody = str1 & RangetoHTML(rg1) & str2 & .HTMLBody      
    
  End With
  On Error GoTo 0
  
Set OutMail = Nothing
Set OutApp = Nothing
    


End Sub
[B]

 

[MarinheiroQ]

It's probably easier to have a function that detects if the cell has only black colored text and turn it into RGB(0, 112, 192) and place that function after the execution of the ones that color the "Aguarda resolução" and the text thats after "|". That way it will color all that has both those arguments and the cells that d'ont have them turn blue. I haven't found anything that those that but i'm not the greatest at programming :D