Страницы: 1
RSS
Подсветка ячейки, если в адресе электронной почты входящего сообщения (активного окна) есть часть, указанная в этой ячейке
 
Доброго всем дня!
В первой строке в диапазоне Q1:AF1 в ячейках перечислены части адресов почты, с которых поступает информация. Адреса разные, но часть адреса всегда одинакова (в зависимости от региона), например PetrovPP@dvgd.ru или SidorovMM@klgd.ru (всего 16 различных окончаний, которые и перечислены в ячейках первой строки). В данном случае письма приходят и первая часть до "@" может меняться по фамилии, а после "@" dvgd.ru или klgd.ru  неизменно.
Как бы реализовать такую фишку, чтобы если во входящем (выделенном в почте Оутлук) сообщении есть часть адреса из первой строки, то ячейка, содержащая эту часть подсвечивалась цветом по Worksheet_SelectionChange в диапазоне "G:G" например (цвет беру из определенных ячеек), и по клику на А1 например заливалась предыдущим цветом какой был (также из определенных ячеек цвет). Если письмо с "левого" адреса и части после "@" в первой строке нет, то ничего не меняется соответственно.
Надеюсь внятно объяснил, т.к. файл выложить нет возможности - корпоративный интернет, скачать можно, выложить - нет.
Цель задачи - не гадать, из какого региона информация, а наглядно видеть для дальнейших определенных действий.
Буду благодарен за помощь!
 
Код
Sub CheckSelectedMailItem()
    MailRangeJob Range("A1:B1")
End Sub

Sub MailRangeJob(rr As Range)
    Dim oOutlook As Object 'Outlook.Application
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    Dim MailItem1 As Object 'MailItem
    Set MailItem1 = oOutlook.ActiveExplorer.Selection.Item(1)
    Dim sMail As String
    sMail = MailItem1.SenderEmailAddress
    On Error GoTo 0
    If sMail <> "" Then
        Dim cl As Range
        For Each cl In rr.Cells
            If InStr(sMail, cl.Value) > 0 Then
                cl.Interior.Color = RGB(200, 200, 200)
            Else
            End If
        Next
    End If
End Sub
 
С файлом-примером проще понять помогать.
Алексей М.
 
МатросНаЗебре,  8-0  работает!!! Одно "НО" - как убрать выделение из строки, когда оно мне не надо (т.е. необходимое действие выполнил и по нажатию выделение стало предыдущим цветом (из ячейки "R1" например)? И при переходе на сообщение из другого региона выделение срабатывает, но выделение предыдущего остается, а надо чтобы очистилось (стало прежнего цвета из ячейки R1).
Код
Sub MailRangeJob(rr As Range)
    Dim oOutlook As Object 'Outlook.Application
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    Dim MailItem1 As Object 'MailItem
    Set MailItem1 = oOutlook.ActiveExplorer.Selection.Item(1)
    Dim sMail As String
    sMail = MailItem1.SenderEmailAddress
    On Error GoTo 0
    If sMail <> "" Then
        Dim cl As Range
        For Each cl In rr.Cells
            If InStr(sMail, cl.Value) > 0 Then
                cl.Interior.Color = Range("Q1").Interior.Color 'RGB(200, 200, 200)
            Else
            End If
        Next
    End If
End Sub
Изменено: evg_glaz - 29.11.2023 11:08:28
 
Код
Range("A1:B1").Interior.Pattern = xlNone
 
МатросНаЗебре, Очередное ОООгромное спасибо!!!!
Успехов и хорошего дня!!!
Страницы: 1
Наверх