通过Excel表

时间：2017-05-09 19:38:01

标签： excel vba excel-vba excel-2010 outlook-2010

我正在尝试通过电子邮件发送到表格中的所有电子邮件地址，主题行是相应的订单号或数字。

该表有五列 - “行号”，“订单号”，“Suppler / Manf.Item编号”，“供应商名称”和“电子邮件地址”

可能有重复项，但主题必须只包含一次PO。

不需要CC或BCC

电子邮件正文列出了PO及其关联的订单项。

  

您好，我们需要更新以下内容：

     

EX
  PO86001763
  第2项   第1项

     

请发送有关这些订单项状态的更新。   提供以下内容：装箱单，跟踪号和更新的发货日期。

（这些能够被编辑将是一个福音）

该表由导入和格式宏组成，它将始终采用相同的格式，但将包含不同的数据。数据量可以根据周来增加或减少。

这是我的尝试。

Private Sub CommandButton2_Click()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Dim I As Integer
Dim X As Integer
Dim C As Object
Dim firstaddress As Variant
Dim Nrow As Boolean

Set tb = ActiveSheet.ListObjects("Table10")

For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
    emAddress = tb.DataBodyRange.Cells(I, tb.ListColumns("Email Address").Index)
    For X = LBound(myArray1) To UBound(myArray1)
        On Error Resume Next
        If emAddress = myArray1(X) Then GoTo goToNext
    Next X
    On Error GoTo 0
    subjectLine = "Order(s) # "
    ReDim Preserve myArray1(1 To nameCounter)
    myArray1(nameCounter) = emAddress
    nameCounter = nameCounter + 1
    lineCounter = 1
    With tb.ListColumns("Email Address").Range
        Set C = .Find(emAddress, LookIn:=xlValues)
        If Not C Is Nothing Then
            firstaddress = C.Address
            Beep
            arrayCounter = arrayCounter + 1
            Do
                Nrow = C.Row - 1
                If lineCounter = 1 Then
                    subjectLine = subjectLine & tb.DataBodyRange.Cells (Nrow, tb.ListColumns("Order Number").Index)
                    lineCounter = lineCounter + 1
                    bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
                Else:
                    subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index)
                    bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
                End If

                Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> firstaddress
        End If
        Run SendMailFunction(emAddress, subjectLine, bodyline)
'                        Debug.Print vbNewLine
'                        Debug.Print emAddress
'                        Debug.Print "Subject: " & subjectLine
'                        Debug.Print "Body:" & vbNewLine; bodyline
    End With
goToNext:
Next I
Set C = Nothing
End Sub


Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim I As Integer

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")

For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = emAddress
        .Subject = subjectLine
        .Body = "Hello, We require an update as to the following:" & DNL & bodyline _
              & DNL & _
                "Please Send an update as to the status of these line items " & _
                "providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
Next I

End Function

Generated Email

TABLE IMAGE

2 个答案:

答案 0 :(得分：0)

这适用于我，因为表名是“Table14”

Sub wserlkug()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")


For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
    Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
            .Subject = "Order # " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Order Number").Index)
            .Body = "Hello, We require an update as to the following:" & DNL & "Line #:  " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Line Number").Index) _
                  & DNL & _
                    "Please Send an update as to the status of these line items " & _
                    "providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
            .Send
        End With
        On Error GoTo 0
        Set OutMail = Nothing
Next i



End Sub

您实际上可以使用对象变量“tb”而不是ActiveSheet.ListObjects（“Table14”）....我将其放在那里以显示如何在表中引用行和列。

答案 1 :(得分：0)

以下代码使用电子邮件脚本作为函数，从顶级宏调用。如果这可以解决您的问题，请点击答案

Sub findMethodINtable()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

Set tb = ActiveSheet.ListObjects("Table14")


For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
    emAddress = tb.DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
    For x = LBound(myArray1) To UBound(myArray1)
        On Error Resume Next
        If emAddress = myArray1(x) Then GoTo goToNext
    Next x
        On Error GoTo 0
        subjectLine = "Order(s) # "
        ReDim Preserve myArray1(1 To nameCounter)
        myArray1(nameCounter) = emAddress
        nameCounter = nameCounter + 1
        lineCounter = 1
            With tb.ListColumns("Email Address").Range
                Set c = .Find(emAddress, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Beep
                    arrayCounter = arrayCounter + 1
                    Do
                        nRow = c.Row - 1
                        If lineCounter = 1 Then
                            subjectLine = subjectLine & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
                            lineCounter = lineCounter + 1
                            bodyline = "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
                        Else:
                            subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
                            bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
                        End If

                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
                        Run SendMailFunction(emAddress, subjectLine, bodyline)
'                        Debug.Print vbNewLine
'                        Debug.Print emAddress
'                        Debug.Print "Subject: " & subjectLine
'                        Debug.Print "Body:" & vbNewLine; bodyline
            End With
goToNext:
Next i
Set c = Nothing
End Sub


Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")


    Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = emAddress
            .Subject = subjectLine
            .Body = "Hello, We require an update as to the following:" & DNL & bodyline _
                  & DNL & _
                    "Please Send an update as to the status of these line items " & _
                    "providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
            .Send
        End With
        On Error GoTo 0
        Set OutMail = Nothing



End Function
相关问题
最新问题