在Excel电子表格中从Outlook中搜索数据，然后复制查找到的单元格（在此处找到的单元格旁边的宿舍单元格）

我想创建一个vba脚本，该脚本将在Outlook中创建一个邮件到查找到的地址（从excel）。搜索应基于outlook中选定的邮件（特定字符串-ID）。我知道如何用vba脚本创建电子邮件，但我不知道如何从outlook vba打开和搜索excel中的数据。 下面是一些代码

Sub-SMSKI（）
将objOL设置为Outlook.Application
作为对象的Dim objItem
Dim objFwd作为Outlook.MailItem
像绳子一样变暗
将xlApp作为对象
将sourceWB设置为工作簿
将sourceWS设置为工作表
出错时继续下一步
设置myItem=Application.CreateItem（olMailItem）
变暗rng1 As范围
作为字符串的Dim stresearch
设置xlApp=CreateObject（“Excel.Application”）
Set objOL=应用程序
设置objItem=objOL.ActiveExplorer.Selection（1）
使用xlApp
.Visible=True
.EnableEvents=False
以
strFile=“C:\Users\User\Desktop\SMS.xlsx”'放入文件路径。
设置sourceWB=Workbooks.Open（strFile，False，，，，True）
设置sourceWH=sourceWB.Worksheets（“SalesForm”）
sourceWB.Activate
如果不是，那么objItem什么都不是
strAddr=对象体
如果是“”，那么
'Set objFwd=objItem.CreateItem（olMailItem）
'objFwd.To=strAddr
vText=拆分（strAddr，Chr（13））
strAddr=右（左）（vText（0）、9、8）
strAddr=左侧（strAddr，Len（strAddr）-8）
vText=拆分（strAddr，“”）
vText=拆分（strAddr，Chr（58））
strearch=Right（Left）（vText（0）、9、8）
myItem.Subject=右（左）（vText（0），9，8）
设置rng1=Range（“C:C”）.Find（strSearch，sourceWB.xlValues，sourceWB.xlWhole）
myItem.SentonBehalfName=”mail@bla.com"
myItem.To=？
myItem.Cc=“”
'myItem.Subject=FindWord（strAddr，1）
'objFwd.Sent=False
myItem.Display
'objFwd.Body=“”
myItem.HTMLBody=“重新启动”
其他的
MsgBox“无法从邮件中提取地址。”
如果结束
如果结束
Set objOL=无
设置objItem=Nothing
设置objFwd=Nothing
端接头

修改的代码 此代码打开SMS.xlsx，但不从邮件中搜索特定的id。（显然不复制） 如何更改此代码以实现我的目标？

选项显式
子测试GetValueFromExcel（）
将ReturnedValue设置为字符串
将搜索值作为变量
将objOL设置为Outlook.Application
作为对象的Dim objItem
Dim objFwd作为Outlook.MailItem
像绳子一样变暗
变暗vText作为变量
将myItem设置为对象
将WbkSrc设置为工作簿
将WshtSrc设置为工作表
Dim xlApp作为新的Excel.Application
出错时继续下一步
设置myItem=Application.CreateItem（olMailItem）
Set objOL=应用程序
设置objItem=objOL.ActiveExplorer.Selection（1）
使用xlApp
.Visible=True“减慢执行速度，但在调试过程中有帮助
.EnableEvents=False
设置WbkSrc=.Workbooks.Open（文件名：=Environ（“UserProfile”）和“\Desktop\SMS.xlsx”）
以
使用WbkSrc
设置WshtSrc=.Worksheets（“SalesForm”）
以
如果不是，那么objItem什么都不是
strAddr=对象体
如果是“”，那么
'Set objFwd=objItem.CreateItem（olMailItem）
'objFwd.To=strAddr
vText=拆分（strAddr，Chr（13））
strAddr=vText（2）
strAddr=左侧（strAddr，Len（strAddr）-8）
vText=拆分（strAddr，Chr（58））
myItem.Subject=右（左）（vText（0），9，8）
SearchValue=右（左（vText（0）、9、8）
ReturnedValue=GetValueFromExcel（WshtSrc，CStr（SearchValue））
myItem.SentOnBehalfOfName=“mateusz。cymerman@snt.pl"
myItem.To=返回的值
myItem.CC=“”
myItem.Display
myItem.HTMLBody=“重新启动”
WbkSrc.Close SaveChanges:=False
设置WbkSrc=Nothing
其他的
MsgBox“未选择任何内容。”
如果结束
使用xlApp
.EnableEvents=False
退出
以
Set objOL=无
设置objItem=Nothing
设置objFwd=Nothing
设置xlApp=Nothing
如果结束
端接头
函数GetValueFromExcel（ByRef Wsht作为工作表，ByVal SearchValue作为字符串）作为字符串
变暗Rng As范围
与Wsht
设置Rng=.Columns（“B”）.Find（What:=SearchValue，After:=.Range（“B1”），LookIn:=xlValues_
查看：=xlother，搜索顺序：=xlByRows_
SearchDirection:=xlNext，MatchCase:=False_
SearchFormat:=False）
如果Rng不算什么，那么
'未找到SearchValue
GetValueFromExcel=“”
其他的
'包含SearchValue的行的C列中的返回值
GetValueFromExcel=.cells（Rng.Row，“C”）
如果结束
以
端函数

---

我不喜欢批评别人的英语，因为我早已忘记了我曾经懂的法语和俄语。我相信“发现”应该是“发现”；动词“find”是许多不规则动词中的一个。我不知道“宿舍”是什么意思

您的代码将解码使用资源管理器选择的电子邮件的正文。这意味着用户必须在运行此电子邮件之前选择一封电子邮件。该电子邮件包含您希望在工作簿中找到的字符串。如果不理解这种做法的原因，我无法提供任何建议，但这对我来说似乎很奇怪

您没有说明搜索工作表“SalesForm”的原因，也没有说明在找到搜索值时将执行的操作。我已经从包含搜索值的行的D列返回了值。对于其他列，可以用字母或数字替换“D”。如果你的需求更复杂，你必须对你的需求做出解释

我提供了一个函数

Dim xlApp As Object 
Set xlApp = CreateObject("Excel.Application") 

Dim xlApp As New Excel.Application

Dim objOL As Outlook.Application
Dim objItem As Object
Set objItem = objOL.ActiveExplorer.Selection(1)

Dim objItem As Object
Set objItem = ActiveExplorer.Selection(1)

strFile = "C:\Users\User\Desktop\SMS.xlsx"  'Put your file path.
Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)

With xlApp
  Set WbkSrc = .Workbooks.Open(FileName:=Environ("UserProfile") & "\Desktop\SMS.xlsx")
End With

Option Explicit
Sub TestGetValueFromExcel()

  Dim ReturnedValue As String
  Dim SearchValue As Variant
  Dim SearchValues As Variant
  Dim WbkSrc As Workbook
  Dim WshtSrc As Worksheet
  Dim xlApp As New Excel.Application

  SearchValues = VBA.Array("Aaaaa", "Bbbbb", "Fffff", "Hhhhh")

  With xlApp
    .Visible = True   ' Slows execution but helpful during debugging
    .EnableEvents = False
    Set WbkSrc = .Workbooks.Open(FileName:=Environ("UserProfile") & "\Desktop\SMS.xlsx")
  End With
  With WbkSrc
    Set WshtSrc = .Worksheets("SalesForm")
  End With

  For Each SearchValue In SearchValues
    ReturnedValue = GetValueFromExcel(WshtSrc, CStr(SearchValue))
    If ReturnedValue = "" Then
      Debug.Print """" & SearchValue & """ not found"
    Else
      Debug.Print """" & SearchValue & """ returned """ & ReturnedValue & """"
    End If
  Next

  WbkSrc.Close SaveChanges:=False
  Set WbkSrc = Nothing
  With xlApp
    .EnableEvents = False
    .Quit
  End With
  Set xlApp = Nothing

End Sub

Function GetValueFromExcel(ByRef Wsht As Worksheet, ByVal SearchValue As String) As String

  Dim Rng As Range
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Wsht

    Set Rng = .Columns("B").Find(What:=SearchValue, After:=.Range("B1"), LookIn:=xlValues, _
                                 LookAt:=xlWhole, SearchOrder:=xlByRows, _
                                 SearchDirection:=xlNext, MatchCase:=False, _
                                 SearchFormat:=False)
    If Rng Is Nothing Then
      ' SearchValue not found
      Debug.Print "SearchValue not found"
      RowLast = .Cells(.Rows.Count, "B").End(xlUp).Row
      For RowCrnt = 2 To RowLast
        Debug.Print Wsht.Name & ".Cells(" & RowCrnt & ",B):"
        Call DsplInHex(.Cells(RowCrnt, "B").Value)
      Next
      Debug.Print "SearchValue:"
      Call DsplInHex(SearchValue)
      GetValueFromExcel = ""
    Else
      ' Return value in column D of row containing SearchValue
      GetValueFromExcel = .Cells(Rng.Row, "C")
    End If

  End With

End Function
Public Sub DsplInHex(Stg As String)

  ' Display Stg in text and hex-digit format.

  ' 19Apr16  Latest date on which it might have been coded.
  ' Pre-     / Hex-digit format only as single row with space between
  ' 17Aug17  \ each character and no padding of short hex values.
  ' 17Aug17  Amended to display text value of characters as well as hex values
  '          and for fixed width display with position within string upto 999.

  Dim ChrGt255 As Boolean
  Dim ChrLng As Long
  Dim ChrStr As String
  Dim LineHex As String
  Dim LineTxt As String
  Dim PadLen As Long
  Dim Pos As Long

  ' Check for (1) all characters at most two hex-digits or (2) at least
  ' one character being more than two hex-digits
  ChrGt255 = False
  For Pos = 1 To Len(Stg)
    If AscW(Mid(Stg, Pos, 1)) > 255 Then
      ChrGt255 = True
    End If
  Next

  If ChrGt255 Then
    ' Need upto four hex-digits per character
    PadLen = 4
  Else
    ' Need at most two hex-digits per character
    PadLen = 2
  End If

  LineHex = "   |"
  LineTxt = "---|"
  For Pos = 0 To 9
    LineHex = LineHex & " " & PadL(Chr$(Asc("0") + Pos), PadLen)
  Next
  LineTxt = PadR(LineTxt, Len(LineHex), "-")

  For Pos = 0 To Len(Stg) - 1
    If Pos Mod 10 = 0 Then
      Debug.Print LineHex    ' Output heading or previous line
      Debug.Print LineTxt
      ' Initialise next line
      LineHex = PadL(Format(Pos, "###"), 3, "0") & "|" ' Position of first character on line
      LineTxt = "   |"
    End If
    ChrStr = Mid(Stg, Pos + 1, 1)
    ChrLng = AscW(ChrStr)
    If ChrLng < 0 Then
      ' Character is &H8000& or above and the top bit is negative
      ChrLng = ChrLng + 65536
    End If

    If ChrLng < 32 Or (ChrLng >= 127 And ChrLng < 160) Then
      ' Control character (non-display)
      ChrStr = "nd"
    End If
    LineHex = LineHex & " " & PadL(Hex(ChrLng), PadLen)
    LineTxt = LineTxt & " " & PadL(ChrStr, PadLen)
  Next
  Debug.Print LineHex    ' Output final line
  Debug.Print LineTxt

End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with leading PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Sep15 Coded
  ' 20Dec15 Added code so overlength strings are not truncated
  ' 10Jun16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadL = Str
  Else
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
  End If

End Function
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with trailing PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Nov15 Coded
  ' 15Sep16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadR = Str
  Else
    PadR = Left$(Str & String(PadLen, PadChr), PadLen)
  End If

End Function