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]

When no | is found, the i value would be 0. Therefore, the code can be easily modified to change font color to blue

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
    Else
        cell.Font.Color = vbBlue
    End If
Next
On Error GoTo 0

End Sub

I've not done any Outlook work to try anything on it. Not sure I fully understood what you want. Looks like you cannot copy the text with partial color in a cell as it was.

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

is copied as all black.

If you use Ctrl+C and Ctrl+V, you should get the result as it is.

Your code

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

will not perform Ctrl+C and Ctrl+V

You can just

Set rng = Range("B3")
Set TempWB = Workbooks.Add(1)

rng.Copy TempWB.Sheets(1).Cells(1)
TempWB.Sheets(1).Columns(1).AutoFit

 

[MarinheiroQ]

Hi, again!

Managed to make it work with outlook copying the colors correctly using your tips and right now is turning out great!

Right now i'm in need of your expertise again :D

I'm trying to get some way of detecting a string of text and when detected create a range from that detected string to the last equal string found ill try to explain:

I want to find for example the first "H080" and make a range from ("B1", "D3") then find the first "D605" and create a range from ("B4", "D5"). I want to be able to find the first string and the last that are equal and create a certain range which in this case doesn't contain the column where I'm searching the strings.

Why do i need this you ask... I need it to make an email that has more than one table and that has spaces between where i write something, im using this code right now with one range only but i need to split the table between those extra strings:

Sub Mail()

Dim OutApp As Object
Dim OutMail As Object
Dim rg1 As Range, rg2 As Range             'Here i have my ranges but im only using rg1 because im not able to split the table
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)) 'This is my range which is not dynamic, it is static and doesn't allow me to create multiple tables to send to my email
'Set rg2 = Sheets("Sheet1").Range(Cells(9, 1), Cells(14, 3))     

str1 = "<BODY style = font-size:12pt;font-family:Cambria>" & _
"Seguem a baixo os erros, <p> So copiar e colar as tabelas para o relatório.<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     'Here im sending rg1 to my outlook module to create the email with the table, the objetive is to have at least 5 or 6 more "rg" which will make more tables with spaces between etc but first i need to detect the ranges for those tables
    
  End With
  On Error GoTo 0
  
Set OutMail = Nothing
Set OutApp = Nothing
    


End Sub

My email is turning out this way:

And i want it to turn out this way:

My entire code:

Sub GERAL()
Call ModuloA
Call ModuloB
Call ModuloC1
Call ModuloC2
Call ModuloC3
Call ModuloC4
Call ModuloC5
Call ModuloC6
Call ModuloC7
Call ModuloC8
Call ModuloD
Call Mail
End Sub

Sub ModuloA()
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("H5", "H1000").Font.Size = 9
Range("E5", "E1000").Font.Name = "cambria"
Range("F5", "F1000").Font.Name = "cambria"
Range("G5", "G1000").Font.Name = "cambria"
Range("H5", "H1000").Font.Name = "cambria"
Range("E5", "E1000").Borders.LineStyle = xlContinuous
Range("F5", "F1000").Borders.LineStyle = xlContinuous
Range("G5", "G1000").Borders.LineStyle = xlContinuous
Range("H5", "H1000").Borders.LineStyle = xlContinuous
Range("D5", "D1000").Borders.LineStyle = xlContinuous
Range("E5", "E1000").RowHeight = 15
Range("F5", "F1000").RowHeight = 15
Range("G5", "G1000").RowHeight = 15
Range("H5", "H1000").RowHeight = 15
Range("H5").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 ModuloC7()
Call Modulocor2(Selection, "AGUARDA RESOLUÇÃO D+1")
End Sub

Sub ModuloC8()
Call Modulocor2(Selection, "Aguarda resolução D+1")
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
    Else
        cell.Font.Color = RGB(0, 112, 192)
        cell.Font.Italic = True
    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 ModuloD()

Range("D5", "H5").Clear
Range("D6", "H6").Clear

End Sub

Sub Mail()

Dim OutApp As Object
Dim OutMail As Object
Dim rg1 As Range, rg2 As Range              '-Adicionar aqui mais ranges para poder criar-se mais tabelas
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))
'Set rg2 = Sheets("Sheet1").Range(Cells(9, 1), Cells(14, 3))     - Segundo range para criar novas cordenadas para a tabela (adicionar novos ranges nos Dim's e depois aqui se for preciso mais tabelas)

str1 = "<BODY style = font-size:12pt;font-family:Cambria>" & _
"Seguem a baixo os erros, <p> So copiar e colar as tabelas para o relatório.<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      '-Se se quiser mais do que uma tabela adicionar aqui o RangetoHTML(rg2) etc.
    
  End With
  On Error GoTo 0
  
Set OutMail = Nothing
Set OutApp = Nothing
    


End Sub

My outlook calling module:

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
   Set rng = Range("D5", "H1000")
Set TempWB = Workbooks.Add(1)

rng.Copy TempWB.Sheets(1).Cells(1)
TempWB.Sheets(1).Columns(1).AutoFit
TempWB.Sheets(1).Columns(2).AutoFit
TempWB.Sheets(1).Columns(3).AutoFit
TempWB.Sheets(1).Columns(4).AutoFit
TempWB.Sheets(1).Columns(5).AutoFit
TempWB.Sheets(1).Columns(1).HorizontalAlignment = xlLeft
TempWB.Sheets(1).Columns(1).VerticalAlignment = xlCenter
TempWB.Sheets(1).Columns(2).HorizontalAlignment = xlLeft
TempWB.Sheets(1).Columns(2).VerticalAlignment = xlCenter
TempWB.Sheets(1).Columns(3).HorizontalAlignment = xlLeft
TempWB.Sheets(1).Columns(3).VerticalAlignment = xlCenter
TempWB.Sheets(1).Columns(4).HorizontalAlignment = xlLeft
TempWB.Sheets(1).Columns(4).VerticalAlignment = xlCenter
TempWB.Sheets(1).Columns(5).HorizontalAlignment = xlLeft
TempWB.Sheets(1).Columns(5).VerticalAlignment = xlCenter


    '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

 

[Zot]

Sorry for late reply. I 'm not really familiar on how to navigate this forum and was at lost to find where your posting was.

You should have install and learn how to use XL2BB (icon on the right). That way you can copy and paste range of your spreadsheet to paste on your post. That way helpers won't have to retype everything to test the code. Even formula also will be automatically displayed.

You have long description there but my attention was on how to get a range with similar end tag. I presumed that they are grouped together. I also have no idea how you are going to input that identifying tag into the code. Anyway, I gave you a sample on how this can be done. The tag is hard coded in my code sample.

The rngA would be the captured range. You can use debug.Print to display the result.

Sub Test()

Dim strFind As String
Dim n As Long, eRow As Long
Dim rngA As Range, rngSearch As Range, rngFound As Range
Dim ws As Worksheet
Dim wb As Workbook

Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")                        ' Change as required

eRow = ws.Cells(Rows.Count, "A").End(xlUp).Row    ' Get the last row of data in column A
Set rngSearch = ws.Range("A1", "A" & eRow)

strFind = "H080"
With rngSearch
    Set rngFound = .Find(strFind, .Cells(.Cells.Count), LookAt:=xlPart)
End With
If Not rngFound Is Nothing Then
    For n = rngFound.Row To eRow
        If Not ws.Range("A" & n) Like "*" & strFind & "*" Then
            Set rngA = ws.Range("B" & rngFound.Row, "D" & (n - 1))
            Exit For
        End If
    Next
Else
    MsgBox "No such string found"
End If

End Sub