vba , higlight cells if it contains anything from criteria

[Mallesh23]

Hi Team,

Below code works for exact cells match for list of Array value,
Now I am looking for Contains, instead of exact match.

Example-
if Array value Contain Red, and Cell value Contain Redish,
then Still it has bold that cell. Because Red is Contained in cell value....



Sub test()
Dim ar As Variant
ar = WorksheetFunction.Transpose(Sheet1.Range("G2:g5").Value) 'array("Green",Red","Yellow"
or
' ar = Sheet1.Range("G2:g5").Value)

Dim lr As Long
Dim i As Long

lr = Sheet1.Range("a1000").End(xlUp).Row
For i = 2 To lr 'List of Color
If IsNumeric(Application.Match(Sheet1.Cells(i, 1).Value, ar, 0)) Then
Sheet1.Cells(i, 1).Font.Bold = True
End If
Next i

End Sub


Regards,
mg

 

[DanteAmor]

Try this

Sub test()
  Dim r As Range, lr As Long, i As Long
  Set r = Sheet1.Range("G2:G5")
  lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To lr 'List of Color
    If Evaluate("=SUM(IF(ISNUMBER(SEARCH(" & r.Address & "," & Sheet1.Range("A" & i).Address & ")),1,0))") > 0 Then
      Sheet1.Range("A" & i).Font.Bold = True
    End If
  Next i
End Sub

 

[Mallesh23]

Hi DanteAmor,

Superbbbb!!!!!!!! it is working, thanks a lot for your help !!


Regards,
mg

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[Mallesh23]

Hi DanteAmor,

the above vba code worked when I put data in single workbook, but when i tried it in my actual project, it didn't worked,
I am sure I am making some mistake,

Can you plz suggest any other way of doing it. Can we use wildCard in Match function and search in array.

ar = WorksheetFunction.Transpose(Sheet1.Range("G2:g5").Value) 'array("Green",Red","Yellow")
If IsNumeric(Application.Match(Sheet1.Cells(i, 1).Value, ar, 0)) Then
Sheet1.Cells(i, 1).Font.Bold = True



Thanks in advance
mg

 

[Peter_SSs]

Superbbbb!!!!!!!! it is working, thanks a lot for your help !!

Note that will only work correctly if Sheet1 is the active sheet when the code is run and the column G range specified contains no blank cells.

So, if Sheet1 is going to be the active sheet when the code is run & if the column G range contains no blank cells, you could also try this

Sub PartialMatch_v1()
  Dim i As Long, lr As Long
  
  lr = Range("A1000").End(xlUp).Row
  With CreateObject("VBScript.RegExp")
    .IgnoreCase = True
    .Pattern = Join(Application.Transpose(Range("G2", Range("G" & Rows.Count).End(xlUp)).Value), "|")
    For i = 2 To lr
      Cells(i, 1).Font.Bold = .test(Cells(i, 1).Value)
    Next i
  End With
End Sub

If Sheet1 may not be the active sheet as suggested by your code (but still assuming no blanks in the column G range) you could try

Sub PartialMatch_v2()
  Dim i As Long, lr As Long
 
  lr = Sheet1.Range("A1000").End(xlUp).Row
  With CreateObject("VBScript.RegExp")
    .IgnoreCase = True
    .Pattern = Join(Application.Transpose(Sheet1.Range("G2", Sheet1.Range("G" & Rows.Count).End(xlUp)).Value), "|")
    For i = 2 To lr
      Sheet1.Cells(i, 1).Font.Bold = .test(Sheet1.Cells(i, 1).Value)
    Next i
  End With
End Sub

If there could be any blank cells in the column G range, then post back with details as a modification would be required.

 

[DanteAmor]

the above vba code worked when I put data in single workbook, but when i tried it in my actual project, it didn't worked,

Can you plz suggest any other way of doing it. Can we use wildCard in Match function and search in array.

What do you mean by "single workbook".
1) do you mean you have 2 books?
2) do you mean you have 2 sheets?
If option 2 has the Texts in sheet1 and the Words in sheet2, for example:

Book1
	A
1	TEXTS
2	Redish
3	green peace white
4	D amor
5
6
Sheet1

Book1
	G
1	Words
2	Red
3	green
4	yellow
5	white
6
7
Sheet2

Then try the following.
You can run the macro on any sheet, (sheet1, sheet2, or even on a third sheet)
You can also select the range of words from G2 to G50, no matter if you have blank cells.

Sub test2()
  Dim r As Range, lr As Long, i As Long
  'Texts on sheet1
  lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
  Sheet1.Range("A2:A" & lr).Font.Bold = False
  'Words on sheet2
  Set r = Sheet2.Range("G2:G50")
  '
  For i = 2 To lr
    If Evaluate("=SUM(IF((" & r.Address(external:=True) & "<>"""")*" & _
                "(ISNUMBER(SEARCH(" & r.Address(external:=True) & "," & _
                Sheet1.Range("A" & i).Address(external:=True) & "))),1,0))") > 0 Then
      Sheet1.Range("A" & i).Font.Bold = True
    End If
  Next i
End Sub

 

[Mallesh23]

Hi Peter,
Thanks for your help, it is working as per my question.
But I am finding difficult to modify as per my requirement.

Requirement
Comparing unique list values of Column G with Column A.
if Column A Contains any value from columns g then


Sheet1.Cells(i,2).value = "Found" (Instead of Bold same cell)

Sheet1.Cells(i, 1).Font.Bold = .test(Sheet1.Cells(i, 1).Value) 'needs to somewhere here.


DaneAmor:- I will check your code and share the result, my column g value is in another workbook, might work now.


Thanks
mg

 

[DanteAmor]

DaneAmor:- I will check your code and share the result, my column g value is in another workbook, might work now.

I don't know if it works in another book, but they are details that you must share in your original request to deliver a complete solution.

 

[Mallesh23]

Hi Dantemor,

Thanks once again for your help... I tested your suggested code, It worked superb!!!

Below was my actual requirement.

Sub PartialMatch_v1()

'Texts on sheet1
Dim wbk As Workbook
Set wbk = Workbooks.Open("C:\Users\User\Desktop\New folder\input_File.xlsx")

Dim r As Range, lr As Long, i As Long
lr = wbk.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row


'Words on sheet2
Set r = ThisWorkbook.Sheets(1).Range("G2:G50")
'
For i = 2 To lr
If Evaluate("=SUM(IF((" & r.Address(external:=True) & "<>"""")*" & _
"(ISNUMBER(SEARCH(" & r.Address(external:=True) & "," & _
wbk.Sheets(1).Range("A" & i).Address(external:=True) & "))),1,0))") > 0 Then
wbk.Sheets(1).Range("D" & i).Value = "Found"
End If
Next i
End Sub


Thanks
mg