Найти текст, заканчивающийся словами, определенными в массиве

Question

Например, я хочу посмотреть, заканчивается ли каждая ячейка от B10 до конца B colomn с «@ yahoo.com», «@ gmail.com», «@rediffmail» .com». Если нет, то он должен окрасить эту конкретную ячейку.

Вот что я пробовал:

Вот минусы:

1. Его ищут весь лист, а не столбец.
2. Его цветная целая строка, а не эта конкретная ячейка
3. Я хочу выделить ячейку, которая не заканчивается вышеуказанными доменами.

Answer 1

вы можете использовать это:
1) вариант использования array для хранения ключей поиска:

Sub test() 
    Dim cl As Range, Data As Range 
    Dim searchTerms, k, trigger% 
    searchTerms = Array("yahoo.com", "gmail.com", "rediff.co") 
    Set Data = Range("B10:B" & [B:B].Find("*", , , , xlByRows, xlPrevious).Row) 
    For Each cl In Data 
     trigger = 0 
     For Each k In searchTerms 
      If LCase(cl.Value2) Like "*" & LCase(k) Then 
       trigger = 1 
       Exit For 
      End If 
     Next k 
     If trigger = 0 Then 
      cl.Interior.ColorIndex = 7 
     Else 
      cl.Interior.Pattern = xlNone 
     End If 
    Next cl 
End Sub 

2) вариант с использованием диапазона с поиском ключей:

Sub test2() 
    Dim cl As Range, Data As Range 
    Dim k As Range, searchTerms As Range, trigger% 
    Dim S1 As Worksheet, S2 As Worksheet 

    Set S1 = Sheets("Sheet1") ' change to sheetname with data for comparing 
    Set S2 = Sheets("Sheet2") ' chanfe to sheetname with search keys 

    Set Data = S1.Range("B10:B" & S1.[B:B].Find("*", , , , xlByRows, xlPrevious).Row) 
    Set searchTerms = S2.[A1:A3] '"yahoo.com", "gmail.com", "rediff.co" 
    For Each cl In Data 
     trigger = 0 
     For Each k In searchTerms 
      If LCase(cl.Value2) Like "*" & LCase(k.Value2) Then 
       trigger = 1: Exit For 
      End If 
     Next k 
     If trigger = 0 Then 
      cl.Interior.ColorIndex = 7 
     Else 
      cl.Interior.Pattern = xlNone 
     End If 
    Next cl 
End Sub 

3) вариантные с использованием scripting.dictionary и диапазон с поисковыми запросами:

Sub test3() 
    Dim cl As Range, Data As Range, Cnt As Long 
    Dim S1 As Worksheet, S2 As Worksheet 
    Dim searchTerms As Object, WrdArray() As String 
    Set searchTerms = CreateObject("Scripting.Dictionary") 
    searchTerms.comparemode = vbTextCompare 

    Set S1 = Sheets("Sheet1") ' change to sheetname with data for comparing 
    Set S2 = Sheets("Sheet2") ' chanfe to sheetname with search keys 

    For Each cl In S2.[A1:A4] '"yahoo.com", "gmail.com", "rediff.co", "internal.yahoo.com" 
     If Not searchTerms.exists(cl.Value2) Then 
      searchTerms.Add cl.Value2, Nothing 
     End If 
    Next cl 

    Set Data = S1.Range("B10:B" & S1.[B:B].Find("*", , , , xlByRows, xlPrevious).Row) 
    Cnt = 0 
    For Each cl In Data 
     WrdArray() = Split(cl.Value2, "@") 
     If Not searchTerms.exists(Split(cl.Value2, "@")(UBound(WrdArray()))) Then 
      cl.Interior.Color = vbYellow: Cnt = Cnt + 1 
     Else 
      cl.Interior.Pattern = xlNone 
     End If 
    Next cl 
    If Cnt > 0 Then 
     Msgbox "Total count of incorrect entries is [" & Cnt & _ 
     "] all discrepancies have been highlighted with Yellow!" 
    End If 
End Sub