Search Excel Worksheet for text highlighted in Outlook email - excel

Question

Everyday I get emails with project numbers on them. I usually highlight and copy the project number from the email, click on my excel spreadsheet (WI_Design_Tracker), ctrl + F (to find) and paste the project number into the find field, then Find Next. I'm trying to create a macro that will shorten the process since I do it a hundred times a day. I found a macro that does the opposite (finds a highlighted number in Excel and searches through Outlook to find the email. I tried to amend it to fit my purposes but it's above my skill level. Any help would be greatly appreciated. Here's the code I'm trying to convert to search my Excel worksheet for the project number I have highlighted on an Outlook email.
'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

Thanks for the link Tim. That was much simpler. I'd had seen that code before but wasn't able to make it work so I tried again. Here's what I ended up with. It could still use some tweaking and error handling, but this is what's working for now:
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