Solved: Highlighting a specific Text in excel sheet by macro

[NM123]

Hi, I would like to highlight particular TEXT in the cell to be in BOLD and in Color.

Please let me know , how can i get this by Macro.


Regards,
NM

[frank_m]

Try
[vba]
Sub BoldandColor_Part_of_String()
Application.ScreenUpdating = False

With Range("A1")

.Characters(Start:=4, Length:=6).Font.Bold = True

.Characters(Start:=4, Length:=6).Font.ColorIndex = 3

End With
Application.ScreenUpdating = True
End Sub
[/vba]
Or does the code need to search for a word, then color and bold it? As that will be different. Above my head a little.

[mancubus]

hi and wellcome to VBAX.

record a macro and see what comes...

assumuming string to be highlighted is in ActiveCell
[VBA]
With ActiveCell.Characters(Start:=9, Length:=5).Font
.Color = vbRed
End With
[/VBA]

starting character and the length of characters must be specified.
you may wish to find and assign to variables. if so, you can use InStr, InStrRev, Len, etc functions.

[NM123]

Hi All,
Thanks for your response.
My requirement is, I have two specific words "Now :" and "Was :" in the sheet, which explains about the two versions changes.I want to highlight those two words in the excel sheet which will be clearly visible. I would like to share the code which i use for comparion of 2 version of sheets.

Sub test() 
    Dim a, i As Long, ii As Long, w(), temp, flg As Boolean 
    With Workbooks.Open(ThisWorkbook.Path & "\LMSws1.xls") 
        a = .Sheets(1).Range("a1").CurrentRegion.Value 
        .Close False 
    End With 
    Redim w(1 To UBound(a, 2)) 
    With CreateObject("Scripting.Dictionary") 
        .CompareMode = 1 
        For i = 2 To UBound(a, 1) 
            For ii = 1 To UBound(a, 2) 
                w(ii) = a(i, ii) 
            Next 
            .Item(a(i, 1)) = w 
        Next 
        a = ThisWorkbook.Sheets(1).Range("a1").CurrentRegion.Value 
        For i = 2 To UBound(a, 1) 
            If .exists(a(i, 1)) Then 
                w = .Item(a(i, 1)) 
                For ii = 2 To UBound(a, 2) 
                    If w(ii) <> a(i, ii) Then 
                        temp = a(i, ii): a(i, ii) = "" 
                        a(i, ii) = "Was : " & w(ii) & vbLf & _ 
                        "Now : " & temp 
                        flg = True 
                    End If 
                Next 
                If Not flg Then 
                    a(i, 1) = "" 
                    flg = False 
                End If 
            End If 
        Next 
    End With 
    With ThisWorkbook.Sheets(2) 
        With .Range("a1").Resize(UBound(a, 1), UBound(a, 2)) 
            .Value = a 
            On Error Resume Next 
            .Columns(1).SpecialCells(4).EntireRow.Delete 
            On Error Goto 0 
        End With 
    End With 
     
End Sub

I hope this clears you my requirements.

Regards,
NM

[mancubus]

perhaps..

[vba]
Dim strHL
Dim Cll As Range, rng As Range
Dim j As Integer

With ThisWorkbook.Sheets(2)
Set rng = .Range("A1").Resize(UBound(a, 1), UBound(a, 2))
rng.Value = a
strHL = Array("Now :", "Was :")
For j = LBound(strHL) To UBound(strHL)
For Each Cll In rng
If InStr(Cll, strHL(j)) <> 0 Then
Cll.Characters(, 5).Font.Color = vbRed
'Cll.Characters(, 3).Font.Color = vbRed '" :" exluded
End If
Next Cll
Next j
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
End With

End Sub
[/vba]

[NM123]

Hi,
the above code throwing error"Type Mismatch" while running separtely.
Set rng = .Range("A1").Resize(UBound(a, 1), UBound(a, 2))
rng.Value = a

But i run the above code along with the code i provided, then it is highlighting only the "Was :" text. the "Now :" text remains the same.can you please let me know on this.

Appreciate your help.

Regards,
NM

[mancubus]

if you want to call the sub from within another procedure, try.

[vba]
Sub MacroTest()
Dim strHL
Dim Cll As Range, rng As Range
Dim j As Integer
With ThisWorkbook.Sheets(1)
Set rng = .Range("A9").Resize(20, 10) 'sample range
strHL = Array("Now :", "Was :")
For j = LBound(strHL) To UBound(strHL)
For Each Cll In rng
If InStr(Cll, strHL(j)) <> 0 Then
Cll.Characters(, 5).Font.Color = vbRed
End If
Next Cll
Next j
End With
End Sub
[/vba]

this code worked for me...

[NM123]

Hi Sir,
I wondering if it is working for you then why not for me !!! i am really struggling.
I have added the code with my compare code. Please do have a look and let me know where i am being wrong. Its really getting tough learning for me.

 
Sub test()
Dim a, i As Long, ii As Long, w(), temp, flg As Boolean
With Workbooks.Open(ThisWorkbook.Path & "\WMS - Requirements_06-28-11.xls")
a = .Sheets(1).Range("a1").CurrentRegion.Value
.Close False
End With
ReDim w(1 To UBound(a, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
For ii = 1 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Item(a(i, 1)) = w
Next
a = ThisWorkbook.Sheets(1).Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If .exists(a(i, 1)) Then
w = .Item(a(i, 1))
For ii = 2 To UBound(a, 2)
If w(ii) <> a(i, ii) Then
temp = a(i, ii): a(i, ii) = ""
a(i, ii) = "Was : " & w(ii) & vbLf & _
"Now : " & temp
flg = True
End If
Next
If Not flg Then
a(i, 1) = ""
flg = False
End If
End If
Next
End With
With ThisWorkbook.Sheets(2)
With .Range("a1").Resize(UBound(a, 1), UBound(a, 2))
.Value = a
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
End With
End With
Dim strHL
Dim Cll As Range, rng As Range
Dim j As Integer
With ThisWorkbook.Sheets(1)
Set rng = .Range("A9").Resize(20, 10) 'sample range
strHL = Array("Now :", "Was :")
For j = LBound(strHL) To UBound(strHL)
For Each Cll In rng
If InStr(Cll, strHL(j)) <> 0 Then
Cll.Characters(, 5).Font.Color = vbRed
End If
Next Cll
Next j
End With
End Sub

[mancubus]

[vba]Set rng = .Range("A9").Resize(20, 10) 'sample range
[/vba]

this was for representing purposes only. change it to actual range where "Was :"s and "Now :"s are present, which i believe would be defined by:
[vba]Set rng = .Range("a1").Resize(UBound(a, 1), UBound(a, 2))
[/vba]

or if you can upload your file, will do it for you

[NM123]

Sir,
I have attached the sheet. Please do have a look.

Thanking You,
NM

[mancubus]

it seems i also need "WMS - Requirements_06-28-11.xls" file to determine the size of the range into which array elements are pasted.

but never mind.
i added variables to do that.

that code provided makes only "Was :"s highlighted. because you did not mention that they were in the same cells. maybe that point is clear from entirety of your code but i did not go through all your code.

below may give you what you need.

[vba]
Sub test()

Dim a, w(), temp, strHL
Dim flg As Boolean
Dim cll As Range, rng As Range
Dim i As Long, ii As Long, j As Long
Dim LastRow As Long, LastCol As Long, SelStart As Long
Dim flg As Boolean

With Workbooks.Open(ThisWorkbook.Path & "\LMSws1.xls")
a = .Sheets(1).Range("a1").CurrentRegion.Value
.Close False
End With

ReDim w(1 To UBound(a, 2))

With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
For ii = 1 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Item(a(i, 1)) = w
Next
a = ThisWorkbook.Sheets(1).Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If .exists(a(i, 1)) Then
w = .Item(a(i, 1))
For ii = 2 To UBound(a, 2)
If w(ii) <> a(i, ii) Then
temp = a(i, ii): a(i, ii) = ""
a(i, ii) = "Was : " & w(ii) & vbLf & _
"Now : " & temp
flg = True
End If
Next
If Not flg Then
a(i, 1) = ""
flg = False
End If
End If
Next
End With

With ThisWorkbook.Sheets(2)
With .Range("a1").Resize(UBound(a, 1), UBound(a, 2))
.Value = a
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
End With

LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
strHL = Array("Now :", "Was :")
For j = LBound(strHL) To UBound(strHL)
For Each cll In rng
If InStr(cll, strHL(j)) <> 0 Then
SelStart = InStr(cll, strHL(j))
cll.Characters(SelStart, 5).Font.Color = vbRed
End If
Next cll
Next j
End With

End Sub
[/vba]

[NM123]

Thanks a lot for the Information Sir !!!