PDA

View Full Version : Solved: Highlighting a specific Text in excel sheet by macro



NM123
11-14-2011, 11:42 PM
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
11-15-2011, 12:16 AM
Try

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

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
11-15-2011, 12:21 AM
hi and wellcome to VBAX.

record a macro and see what comes...

assumuming string to be highlighted is in ActiveCell

With ActiveCell.Characters(Start:=9, Length:=5).Font
.Color = vbRed
End With


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
11-15-2011, 12:35 AM
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
11-15-2011, 01:12 AM
perhaps..


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

NM123
11-15-2011, 01:30 AM
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
11-15-2011, 02:15 AM
if you want to call the sub from within another procedure, try.


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


this code worked for me...

NM123
11-15-2011, 02:33 AM
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
11-15-2011, 03:15 AM
Set rng = .Range("A9").Resize(20, 10) 'sample range


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:
Set rng = .Range("a1").Resize(UBound(a, 1), UBound(a, 2))


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

NM123
11-15-2011, 03:24 AM
Sir,
I have attached the sheet. Please do have a look.

Thanking You,
NM

mancubus
11-15-2011, 05:33 AM
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.


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

NM123
11-17-2011, 09:14 PM
Thanks a lot for the Information Sir !!!