是否有 VBA 公式可以将基于单元格值的行返回与向多个收件人创建 Outlook 电子邮件结合起来？

Question

我有一个包含多张工作表的工作簿（“所有数据”）。该工作簿很大，需要 3 分钟才能加载。结果我需要打开使用路径，然后延迟3分钟才开始提取。

我想根据 B 列（“名称”）从一张表（“内容”）中提取行。我只想从每个返回的行中提取某些列值。这个我可以做。接下来的部分我正在努力。

我有一个单独的查找表（“员工电子邮件”）。 xlsm（“Performance.xlsm”），其中“姓名”中的每个人都有一个相应的电子邮件地址。例如，A2 中的“John”，B2 中的“[电子邮件受保护]”）。我需要宏在目标 WS 中搜索“John”，提取指定列中包含“John”的所有行，然后创建一封 Outlook 电子邮件到 John 的电子邮件（使用“员工电子邮件”表中的查找）并附加上的单张纸。 xlsx 到名为“需要立即采取行动”的电子邮件，然后发送。然后我需要宏循环到“员工电子邮件”表上的下一个名称（例如单元格 A3 上的“Janet”）并重复该过程。如果搜索在目标工作表上查找姓名，但没有找到，我不希望宏生成电子邮件。在运行结束时，我想要一个文本框来说明员工的姓名以前我曾尝试将“Contents”上的值手动复制到 my.xlsm 并纯粹从那里运行。下面的公式使用了这一原理，但因此是一个笨拙、不优雅的解决方案：

Sub ExampleCode()
    Dim fCell As Range
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    'What sheet are we searching?
    Set wsSearch = Worksheets("Contents")
    'Where should we move the data?
    Set wsDest = Worksheets("Johns Actions") 
    
    'Prevent screen flicker
    Application.ScreenUpdating = False
    
    'We will be searching col B
    With wsSearch.Range("B:B")
        'Find the word "John"
        Set fCell = .Find(what:="finished", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        
        'Repeat until we've moved all the records
        Do Until fCell Is Nothing
            'Found something, copy and delete
           
            'Where will we paste to?
            lastRow = wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
            
            'Copy A:O at first. We will do Paste Values so CF doesn't get included
            wsSearch.Cells(fCell.Row, "A").Resize(1, 15).Copy
            wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
            'Now grab AF:AG
            wsSearch.Cells(fCell.Row, "AF").Resize(1, 2).Copy
            wsDest.Cells(lastRow, "P").PasteSpecial Paste:=xlPasteValues
            
            fCell.EntireRow.Delete
            
            'Try to find next one
            Set fCell = .Find(what:="finished", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        Loop
        
        'Resize our table to match new data
        If lastRow <> 0 Then
            wsDest.ListObjects("Table2").Resize wsDest.Range("A4:AG" & lastRow)
        End If
    End With
    
    'Reset
    Application.ScreenUpdating = True
    
End Sub

Answer 1

对此没有现成的解决方案。您需要开发/创建代码来处理工作表数据，并在工作表上列出所需条目时为您发送电子邮件。