VBA Search Multiple value to find match in Cell string

[MHamid]

Hello,

Can anyone let me know if the below is possible? If so, how?

I am looking to create a vba code that will conduct multiple text searches within a cell and highlight the cell (any color) and change the found text to bold and red font. Would this be possible?
I have a list of keywords to search (B2:B90). I manually search for 89 keywords or key phrases against a paragraph that is found in one cell (AJ5). I would like to automate this process instead of manually searching every keyword/key phrase and then update the found word found keyword/key phrase in bold and red font.
Can this be done? If someone can point me to the right direction, that would be helpful .


Thank you,

 

[kevin9999]

Pointing you in the right direction (make the changes as suggested)

Code

Option Explicit
Sub Highlight()
    Dim cellCheck As Range, myCount As Long, i As Long, arr
   
    Set cellCheck = Range("A1") '<< change range to "AJ5"
   
    arr = Range("B2:B5").Value  '<< change range to "B2:B90"
   
    For i = LBound(arr, 1) To UBound(arr, 1)
            For myCount = 1 To Len(cellCheck) - Len(arr(i, 1)) + 1
                If Mid(cellCheck, myCount, Len(arr(i, 1))) = arr(i, 1) Then
                    cellCheck.Characters(myCount, Len(arr(i, 1))).Font.Color = vbRed
                    cellCheck.Characters(myCount, Len(arr(i, 1))).Font.Bold = True
                End If
            Next myCount
    Next i
End Sub

 

[Peter_SSs]

Another possible option with a lot less looping, but note ..

• It is not clear whether your are looking for full words in AJ5 or just text strings. Note the two partial words highlighted in my sample below. Could be whole words if required - subject to possible punctuation issues.
• This code is written for the possibility that less than all B2:B90 cells are filled but there must be no blanks cells within the list in column B.
• Search is not case-sensitive (eg Blue/blue), but could be if needed
• This will only work with your Windows platform, not MacOS

Sub HighlightStrings()
  Dim RX As Object, M As Object
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  With Range("AJ5")
    RX.Pattern = Join(Application.Transpose(Range("B2", Range("B91").End(xlUp)).Value), "|")
    If RX.test(.Value) Then .Interior.Color = vbYellow
    For Each M In RX.Execute(.Value)
      With .Characters(M.FirstIndex + 1, Len(M)).Font
        .Bold = True
        .Color = vbRed
      End With
    Next M
  End With
End Sub

My sample data and results:

 

[MHamid]

Hi Kevin and Peter,

I tested both your codes and they work very well. I know I said that the cell to be checked is AJ5, but I actually need the code to loop through all the cells in column AJ starting from cell AJ2 until the last cell with data in that column to run the same check. Does that make any sense?

Oh also, would it be possible to highlight some words in different color? The keywords/key phrases I have belong to different categories. The table below is my keyword/key phrases search. Column A is the category and column B is the keywords/key phrases to be searched. If color coding them into 7 different colors by category in Column A is not possible. Are there any other suggestions as to how I can tell which keyword/Key phrase found belongs to what category? I don't have any preference to the 7 color coding.

Category	keywords
CoB	CoB
CoB	continuity
CoB	resilienc
CoB	BCP
CoB	RTO
CoB	CoB
CoB	Resilie
CoB	Recovery
CoB	Disaster
CoB	Contienge
CoB	Continu
CoB	Crisis
CoB	Business Impact Analysis
CoB	BIA
EUC	EUC
EUC	End User Computing
EUC	Spreadsheet
EUC	Access DB
EUC	Access Database
Inter-Affiliate	Inter-Affiliate
Inter-Affiliate	ICSA
Inter-Affiliate	Intra-Citi
Inter-Affiliate	affiliate
Inter-Affiliate	service agreement
information security	information security
information security	entitlement
information security	vulnerab
information security	PII
information security	privileged access
information security	access to data
information security	encrypt
information security	personally identifiable information
information security	EERS
information security	EEMS
information security	Functional IDs
PM	Program Management Office
PM	PMO
PM	Program Management
PM	Project Management
PM	CITMS
PM	Citi Project and Program Management Standard
PM	CPPMS
PM	(PM)
PM	PMO governance
PM	(CPMO)
PM	CPMC
PM	Compliance Project Management Office
PM	Citi Program Management Council
TPM	SRM
TPM	3rd party
TPM	add on products
TPM	add-on products
TPM	casp
TPM	co-branded
TPM	cssmp
TPM	esrm
TPM	exit strategy
TPM	external reconciliation
TPM	financial evaluation
TPM	managed service providers
TPM	master service agreement
TPM	non-employee
TPM	Out Sourc
TPM	outsou
TPM	Out-Soure
TPM	performance monitoring
TPM	performance review
TPM	PLSD
TPM	Provider
TPM	Reg 23A
TPM	Reg 23B
TPM	sensitive relationships
TPM	Service Level Agreement
TPM	SLA
TPM	step project
TPM	step steering committee
TPM	Sub Contractor
TPM	subadvis
TPM	sub-advis
TPM	subcontract
TPM	sub-contract
TPM	supplier
TPM	third-party
TPM	TPISA
TPM	vendor
TPM	TPM
TPM	tp
TPM	third party
DM	Data Management

Thank you,

 

[Peter_SSs]

Could you give us some representative sample data for column AJ to test with - say 10 rows that show the sort of variety that may occur in that column?

 

[Peter_SSs]

Could you give us some representative sample data for column AJ to test with - say 10 rows that show the sort of variety that may occur in that column?

See if this with my made-up data does what you want. If there are problems then, as well as detailing those problems, please provide the requested sample data.

Sub HighlightStringsByCategory()
  Dim d As Object, RX As Object, M As Object
  Dim a As Variant
  Dim c As Range
  Dim i As Long, Cat As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  Cat = 2
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then Cat = Cat + 1
    d(a(i, 2)) = Cat
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = Replace(Replace(Join(Application.Transpose(Range("B2", Range("B" & Rows.Count).End(xlUp)).Value), "|"), "(", "\("), ")", "\)")
  For Each c In Range("AJ2", Range("AJ" & Rows.Count).End(xlUp))
    With c
      If RX.Test(.Value) Then .Interior.Color = vbYellow
      For Each M In RX.Execute(.Value)
        With .Characters(M.FirstIndex + 1, Len(M)).Font
          .Bold = True
          .ColorIndex = d(CStr(M))
        End With
      Next M
    End With
  Next c
End Sub

I have your Category/Keyword list in A1:B90 and this is my result.

Due to the short length of some of keywords and the fact that we are matching anywhere in the text, you may find some false-positives showing up as in "topmost" in my AJ2 example above.

 

[MHamid]

Hello,

I don't have sample data because it can be almost anything since the user can write pretty much anything. It's ok if it finds false matches. This is just so the user can focus on the areas in a report where I am extracting data from where they can focus to make a determination.
Code works perfectly with the tweaks I made for the workbook I'll be using it in.
Quick question though, how does the coloring system work? Will it always be the same color for the category? As in, will EUC category always be red or will the first match found be colored red instead?

 

[Peter_SSs]

Will it always be the same color for the category?

Yes each category will always be the same colour - see below.

However, I had made an error with the previous code in that I coloured the background yellow and also one of the categories gets coloured yellow - so any words in that category would be impossible to read.
In the new code below I have changed the background colour to grey if a keyword is found

The categories will always have these colours (assuming the categories retain the same order in your main keyword table)

MHamid.xlsm
	A
1	Category
2	CoB
3	EUC
4	Inter-Affiliate
5	information security
6	PM
7	TPM
8	DM
Sheet3

The slightly changed code is ..

Sub HighlightStringsByCategory_v2()
  Dim d As Object, RX As Object, M As Object
  Dim a As Variant
  Dim c As Range
  Dim i As Long, Cat As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  Cat = 2
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then Cat = Cat + 1
    d(a(i, 2)) = Cat
  Next i
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = Replace(Replace(Join(Application.Transpose(Range("B2", Range("B" & Rows.Count).End(xlUp)).Value), "|"), "(", "\("), ")", "\)")
  For Each c In Range("AJ2", Range("AJ" & Rows.Count).End(xlUp))
    With c
      If RX.Test(.Value) Then .Interior.ColorIndex = 48
      For Each M In RX.Execute(.Value)
        With .Characters(M.FirstIndex + 1, Len(M)).Font
          .Bold = True
          .ColorIndex = d(CStr(M))
        End With
      Next M
    End With
  Next c
End Sub

And sample results re-done and cell AJ7 contains one keyword from each of the 7 categories.