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

Question

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

Sub SMSKI()
    Dim objOL As Outlook.Application
    Dim objItem As Object
    Dim objFwd As Outlook.MailItem
    Dim strAddr As String
    Dim xlApp As Object 
    Dim sourceWB As Workbook 
    Dim sourceWS As Worksheet 
    On Error Resume Next
    Set myItem = Application.CreateItem(olMailItem)

     Dim rng1 As Range
     Dim strSearch As String



    Set xlApp = CreateObject("Excel.Application") 
    Set objOL = Application
    Set objItem = objOL.ActiveExplorer.Selection(1)


    With xlApp 
       .Visible = True 
       .EnableEvents = False 
     End With 

     strFile = "C:\Users\User\Desktop\SMS.xlsx"  'Put your file path.

    Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True) 
    Set sourceWH = sourceWB.Worksheets("SalesForm") 
    sourceWB.Activate 


    If Not objItem Is Nothing Then
        strAddr = objItem.Body
        If strAddr <> "" Then
            ' Set objFwd = objItem.CreateItem(olMailItem)
            ' objFwd.To = strAddr


            vText = Split(strAddr, Chr(13))
            strAddr = Right(Left(vText(0), 9), 8)
            strAddr = Left(strAddr, Len(strAddr) - 8)
            vText = Split(strAddr, " ")
            vText = Split(strAddr, Chr(58))
            strSearch = Right(Left(vText(0), 9), 8)
            myItem.Subject = Right(Left(vText(0), 9), 8)
            Set rng1 = Range("C:C").Find(strSearch, , sourceWB.xlValues, sourceWB.xlWhole)
            myItem.SentOnBehalfOfName = "mail@bla.com"
            myItem.To = ?
            myItem.Cc = ""
            'myItem.Subject = FindWord(strAddr, 1)
            ' objFwd.Sent = False
            myItem.Display
            ' objFwd.Body = ""




            myItem.HTMLBody = "reboot"

        Else
            MsgBox "Could not extract address from message."
        End If
    End If
    Set objOL = Nothing
    Set objItem = Nothing
    Set objFwd = Nothing
End Sub

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

Option Explicit








Sub TestGetValueFromExcel()

  Dim ReturnedValue As String
  Dim SearchValue As Variant
  Dim objOL As Outlook.Application
    Dim objItem As Object
    Dim objFwd As Outlook.MailItem
    Dim strAddr As String
    Dim vText As Variant
    Dim myItem As Object
      Dim WbkSrc As Workbook
  Dim WshtSrc As Worksheet
      Dim xlApp As New Excel.Application

    On Error Resume Next
    Set myItem = Application.CreateItem(olMailItem)
    Set objOL = Application
    Set objItem = objOL.ActiveExplorer.Selection(1)




  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




 If Not objItem Is Nothing Then
        strAddr = objItem.Body
        If strAddr <> "" Then
            ' Set objFwd = objItem.CreateItem(olMailItem)
            ' objFwd.To = strAddr
            vText = Split(strAddr, Chr(13))
            strAddr = vText(2)
            strAddr = Left(strAddr, Len(strAddr) - 8)
            vText = Split(strAddr, Chr(58))
            myItem.Subject = Right(Left(vText(0), 9), 8)


            SearchValue = Right(Left(vText(0), 9), 8)


   ReturnedValue = GetValueFromExcel(WshtSrc, CStr(SearchValue))


            myItem.SentOnBehalfOfName = "mateusz.cymerman@snt.pl"
            myItem.To = ReturnedValue
            myItem.CC = ""

            myItem.Display





            myItem.HTMLBody = "reboot"



  WbkSrc.Close SaveChanges:=False
  Set WbkSrc = Nothing

 Else
        MsgBox "Nothing Selected."
    End If


    With xlApp
    .EnableEvents = False
    .Quit
  End With

  Set objOL = Nothing
    Set objItem = Nothing
    Set objFwd = Nothing
    Set xlApp = Nothing

    End If

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

  Dim Rng As Range

  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
      GetValueFromExcel = ""
    Else
      ' Return value in column C of row containing SearchValue
      GetValueFromExcel = .cells(Rng.Row, "C")
    End If

  End With

End Function

Answer 1

我不喜欢批评别人的英语，因为我早就忘记了我曾经知道的法语和俄语。我认为“找到”应该是“找到”；动词“find”是许多不规则动词之一。我不知道“宿舍”是什么意思。

您的代码会解码使用 Explorer 选择的电子邮件的文本正文。这意味着用户必须在运行此电子邮件之前选择一个电子邮件。该电子邮件包含您希望在工作簿中找到的字符串。在不了解这种方法的原因的情况下，我无法提供任何建议，但这对我来说似乎很奇怪。

您没有说明为什么要搜索“SalesForm”工作表或找到搜索值时会做什么。我已从包含搜索值的行的 D 列返回值。您可以将“D”替换为其他列的字母或数字。如果您的要求更复杂，您将必须提供您所寻求的解释。

我提供了一个函数“GetValueFromExcel”和一个例程来展示如何使用它。您可以复制我的函数并从您的代码中调用它，或者您可以研究我的代码如何工作并构建您自己的版本。

你有：

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

我有：

Dim xlApp As New Excel.Application

用于标识我想要的对象的“New”关键字和“Excel.Application”意味着我不需要 CreateObject 语句。我读到您的方法比我的方法效率略高，但您经常会看到这种不同的方法。

你有：

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

您在 Outlook 中，因此不需要objOL。这与以下内容相同：

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

如你所见，On Error Resume Next 的意思是“不要告诉我任何错误，因为我喜欢神秘的失败。请不要使用此语句，除非您知道自己需要它并且知道如何正确使用它。

你有：

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

Environ("UserProfile") 返回“C:\Users\xxxx”，其中“xxxx”是当前用户。如果您与同事共享此宏，该宏将适应新用户而无需任何更改。

我在 Workbooks.Open 的调用中包含了路径和文件名，以表明它是可能的。

您已为 Workbooks.Open 按其位置指定参数。当参数很明显时，我会这样做，但我不喜欢倒数逗号来计算 False 和 True 的含义。 FileName:= 非常清楚这个参数是什么。您似乎不想修改此工作簿，因此我看不到 ReadOnly:=False 的值。我不相信Editable:=True 是相关的。

sourceWB.Activate 不是必需的。

我的代码如下。将其复制到 Outlook 安装中的一个模块，并在决定如何将其添加到您的例程之前尝试一下。为了测试我的代码，我在桌面上创建了一个名为“SMS.xlsx”的工作簿，将“Aaaaa”等搜索值放在 C 列中，并将返回值放在 D 列中。

宏“GetValueFromExcel”在引用的工作表的 C 列中搜索指定的搜索值。如果找到搜索值，则返回 D 列中的值，如果未找到搜索值，则返回空字符串。

宏“TestGetValueFromExcel”演示了如何使用“GetValueFromExcel”。您将需要替换 SearchValues = VBA.Array("Aaaaa", "Bbbbb", "Fffff", "Hhhhh")。值“Aaaaa”、“Bbbbb”和“Fffff”出现在我的 C 列中。值“Fffff”没有出现在我的 C 列中。将我的值替换为 C 列中的值。

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

更新：GetValueFromExcel 加上DsplInHex、PadL 和PadR 的诊断版本

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