Доброго всем дня! В первой строке в диапазоне 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
МатросНаЗебре, работает!!! Одно "НО" - как убрать выделение из строки, когда оно мне не надо (т.е. необходимое действие выполнил и по нажатию выделение стало предыдущим цветом (из ячейки "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