Поиск в Excel Excel для текста, выделенного в электронной почте Outlook

Question

Каждый день я получаю электронные письма с номерами проектов на них. Я обычно выделяю и копирую номер проекта из электронного письма, нажимаю на электронную таблицу Excel (WI_Design_Tracker), ctrl + F (чтобы найти) и вставляю номер проекта в поле поиска, затем Find Next. Я пытаюсь создать макрос, который сократит процесс, так как я делаю это сто раз в день. Я нашел макрос, который делает обратное (находит выделенный номер в Excel и ищет в Outlook, чтобы найти электронную почту. Я пытался изменить его, чтобы он соответствовал моим целям, но он выше моего уровня квалификации. Любая помощь будет принята с благодарностью. Вот код Я пытаюсь преобразовать в свой лист Excel номер проекта, который я выделил в электронном письме Outlook.

'Code:
Option Explicit

Public Sub Search_Outlook_Emails()

    Dim outApp As Outlook.Application
    Dim outNs As Outlook.Namespace
    Dim outStartFolder As Outlook.MAPIFolder
    Dim foundEmail As Outlook.MailItem

    Set outApp = New Outlook.Application
    Set outNs = outApp.GetNamespace("MAPI")

    'Start at Inbox's parent folder
    Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent

    'Or start at folder selected by user
    'Set outStartFolder = outNs.PickFolder


    If Not outStartFolder Is Nothing Then

        Set foundEmail = Find_Email_In_Folder(outStartFolder, ActiveCell.Value)

        If Not foundEmail Is Nothing Then

            If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
                      "Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
                      "Open the email?", vbYesNo, "'" & ActiveCell.Value & "' found") = vbYes Then

                foundEmail.Display

            End If

        Else

            MsgBox "", vbOKOnly, "'" & ActiveCell.Value & "' not found"

        End If

    End If

End Sub

Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem

    Dim outItem As Object
    Dim outMail As Outlook.MailItem
    Dim outSubFolder As Outlook.MAPIFolder
    Dim i As Long

    Debug.Print outFolder.FolderPath

    Set Find_Email_In_Folder = Nothing

    'Search emails in this folder

    i = 1
    While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing

        Set outItem = outFolder.Items(i)

        If outItem.Class = Outlook.OlObjectClass.olMail Then

            'Does the findText occur in this email's body text?

            Set outMail = outItem
            If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail

        End If

        i = i + 1

    Wend

    DoEvents

    'If not found, search emails in subfolders

    i = 1
    While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing

        Set outSubFolder = outFolder.Folders(i)

        'Only check mail item folders

        If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)

        i = i + 1

    Wend

End Function

Answer 1

Спасибо за ссылку Тим. Это было намного проще. Я видел этот код раньше, но не смог заставить его работать, поэтому я попробовал снова. Вот чем я закончил. Он все еще может использовать некоторые настройки и обработку ошибок, но сейчас это работает:

Sub FindOutlookValue()

Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim WdDoc As Object
Dim strText As String

On Error Resume Next

'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)

With OutMail
    Set olInsp = .GetInspector
    Set wdDoc = olInsp.WordEditor
    strText = WdDoc.Application.Selection.Range.Text
End With

'Find strText in Excel
Dim cl As Range
With Worksheets("MyWorksheet").Cells
    Set cl = .Find(strText, After:=.Range(A1), LookIn:=xlValues)
    If Not cl Is Nothing Then
       cl.Select
    End If
End With

End Sub