按供应商从 Excel for Outlook 电子邮件中提取数据

Question

我有一个供应商列表，我按名称排序，然后使用宏进行遍历并从字段中提取数据片段并将它们放入 Outlook 电子邮件中。非常简单，直到我找到具有多行的供应商，因为然后我需要让代码知道查看该供应商的所有行并提取他们的信息并将其放入电子邮件中的列表中（这样他们就不会收到多封电子邮件一次全部）。

上图是我按供应商排序后的列表示例。因此，我希望每个供应商都有一封电子邮件，但供应商 1 需要他的两条线路的发票、已付金额、检查 ID 和检查 Dt 中的数据。供应商 2 将只有一行，供应商 3 将有 3 行。我需要一种方法让宏知道查看供应商名称（或供应商编号）并知道它需要从下一行提取数据并将其包含在内在同一封电子邮件中，直到到达下一个供应商为止。

我不是程序员，我正在努力让这项工作成功。下面是我到目前为止一直在尝试的示例，但它只为每一行创建一封电子邮件。希望比我聪明的人能帮助我。谢谢。

Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strName1 As String
Dim strDept As String
Dim strName2 As String
Dim lr As Long
Dim oItem As Object
Dim dteSat As Date
Dim nextSat As Date
Dim lastRow As Long
Dim ws As String

           
'Link to Outlook, use GetBoiler function to pull email signature
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

sigString = Environ("appdata") & _
            "\Microsoft\Signatures\Uncashed Checks.htm"
             
               
    If Dir(sigString) <> "" Then
     signature = GetBoiler(sigString)
     Else
     signature = ""
    End If
    
    Select Case Time
       Case 0.25 To 0.5
            GreetTime = "Good morning"
       Case 0.5 To 0.71
            GreetTime = "Good afternoon"
       Case Else
            GreetTime = "Good evening"
    End Select
    
    'Define the date for the next Saturday
    With Item
    K = Weekday(TODAY)
    dteChk = Weekday(TODAY) - 30
    dteSat = Now() + (10 - K)
   
    nextSat = Date + 7 - Weekday(Date, vfSaturday)
    End With
                    
    'Select the currently active sheet and insert a column next to column I, then fill it with the word 'yes'.  The yes values will act as triggers to tell the code to run for that row.
    'Delete first 7 rows of report.  Find the Paid Amt header and then replace that column with a re-formatted one that shows the full numbers with decimals and zeroes.  Change column E
    'to UPPER case using the index and upper functions.
    lr = ActiveSheet.UsedRange.Rows.Count
    lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    Rows("1:7").Select
    Columns("C").SpecialCells(xlBlanks).EntireRow.Delete
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Set rng8 = Range("A1:Z1").Find("Paid Amt")
    Set rng9 = ActiveSheet.Range(rng8, ActiveSheet.Cells(Rows.Count, rng8.Column).End(xlUp).Address)
    rng9.Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    ActiveCell.FormulaR1C1 = "=TEXT(RC[+1],""#.00"")"
    ActiveCell.Copy
    Range(ActiveCell.Offset(350 - ActiveCell.Row, 0), ActiveCell.Offset(1, 0)).Select
    ActiveSheet.Paste
    ActiveCell.Offset.Resize(1).EntireColumn.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Offset.Resize(1).EntireColumn.Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToRight
            
    Range("i2") = "Yes"
    Range("I2").AutoFill Destination:=Range("I2:I" & lr)
    
    [e2:e350] = [INDEX(UPPER(e2:e350),)]
                    
   
'Begin a loop that looks at all the yes values in column I and then begins to create emails.  Define the columns to be used for data by looking for the header names such as Paid Amt.
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
           
    If cell.Value Like "?*@?*.?*" And _
       LCase(Cells(cell.Row, "I").Value) = "yes" Then
        Set OutMail = OutApp.CreateItem(0)
        Set rng8 = Range("A1:Z1").Find("Paid Amt")
        Set foundCell = Cells(cell.Row, rng8.Column)
        Set rng9 = Range("A1:AG1").Find("Check Dt")
        Set foundCell1 = Cells(cell.Row, rng9.Column)
        Set rng12 = Range("A1:AG1").Find("Student Perm Address")
        Set foundcell2 = Cells(cell.Row, rng12.Column)
 
                     
 'Create the actual email data, definiing the body and recipients/names, etc, based on the values in the cells noted below.  Sentonbehalf is the 'From' field.  Change font color
 'using the hexadecimal codes.  The one used here 1F497D is Blue-Gray.
    With OutMail
        strname = Cells(cell.Row, "A").Value
        strName2 = Trim(Split(strname, ",")(1))
        strName3 = Cells(cell.Row, "R").Value
        strName4 = Cells(cell.Row, "E").Value
        
        
        strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because you have an uncashed check that was sent to you over 30 days ago.  " & _
            "Please cash or deposit your check.<br><br>" & _
            "<B>The amount of the check is $" & foundCell & " and is dated " & foundCell1 & ".  The check was mailed to the following address: <br><br>" & _
                "<ul>" & foundcell2 & "<br></B></ul>"

            .SentOnBehalfOfName = "[email protected]"
            .To = cell.Value
            .Subject = "Uncashed Check from Salem State University"
            .HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B>" & "Important Information Regarding Your Student Account </B><br><br><p style=font-size:18.5px> Dear " & strName2 & ", " & strbody & "<br>" & signature & "<HTML><BODY><IMG src='C:\Users\gmorris\Pictures\Saved Pictures\220px-Salem_State_University_logo.png' /></BODY></HTML>"
            .display  'Or use Send
    End With
      
        Set OutMail = Nothing
    End If
Next cell

结束子

Answer 1

如果电子邮件地址已排序：

• 当电子邮件地址与之前的地址相符时：
  绕过创建电子邮件，附加到正文。
• 当有新的电子邮件地址时：
  在创建新电子邮件之前发送现有邮件。

Option Explicit

Sub oneEmail_SortedEmailAddresses()

Dim OutApp As Object
Dim OutMail As Object

Dim strVoucher As String

Dim lr As Long

Set OutApp = CreateObject("Outlook.Application")

lr = ActiveSheet.UsedRange.Rows.Count
    
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean

For i = 2 To lr

    ' Email address
    If ActiveSheet.Range("N" & i).Value <> "" Then
    
        ' One email per email address
        ' This assumes the addresses are sorted
        If ActiveSheet.Range("N" & i).Value <> toAddress Then
        
            If Not OutMail Is Nothing Then
                If refundDescYes = True Then
                    OutMail.display
                Else
                    OutMail.Close 1 ' olDiscard
                End If
            End If
            
            toAddress = ActiveSheet.Range("N" & i).Value
            Debug.Print toAddress
            
            Set OutMail = Nothing
            refundDescYes = False
            
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = toAddress
                .Subject = "Uncashed Check from Salem State University"
            End With
        End If
        
        ' Refund Desc
        If ActiveSheet.Range("I" & i).Value = "Yes" Then
        
            refundDescYes = True
            
            ' Voucher
            strVoucher = Cells(i, "D").Value
            
            With OutMail
                .HTMLBody = .HTMLBody & "<br>" & strVoucher & "<br>"
            End With
                
        End If
      
    End If
    
Next

If Not OutMail Is Nothing Then
    If refundDescYes = True Then
        OutMail.display
    Else
        OutMail.Close 1 ' olDiscard
    End If
End If

Set OutMail = Nothing

Debug.Print "Done."

End Sub