Question

我已编写代码，按制造商名称将数据导出到以制造商命名的新书中。

现在我调整了一个电子邮件宏来自动向制造商发送电子邮件。

我希望自动附加我的文档

中的文件

这是我拥有的，但它什么都没有。

Sub BacklogEmail()
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("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 = "Obsolescence Report for Manufacturer(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("Manufacturer Name").Index)
                            lineCounter = lineCounter + 1
                           ' bodyline = "Manufacturer " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        Else:
                            subjectLine = subjectLine
                            'bodyline = bodyline & vbNewLine & "Manufacturer " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item 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 lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

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

           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
                        Nrow = C.Row - 1
                      If lineCounter = 1 Then
                      Set OutMail = OutApp.CreateItem(0)
       On Error Resume Next
        With OutMail

            .To = emAddress
            .Subject = subjectLine
            .Body = "Hello, attached is an excel file that we require you to complete. " & _
                    "This is required by as we must know when parts are going to become obsolete. " & _
                    "We appriciate your contribution to keeping our databases current. " & _
                    "Thank you for your timely response."
                            .Attachments.Add "U:\\\\" & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ".xlsx"
                            lineCounter = lineCounter + 1

           .Display


     On Error GoTo 0
        Set OutMail = Nothing


End With
End If
End If
End With
End Function

Answer 1

将您的Mem: 32880876k total, 7573308k used, 25307568k free, 192956k buffers Swap: 8241148k total, 0k used, 8241148k free, 4800560k cached PID USER PR NI VIRT RES SHR S %CPU %MEM TIME+ COMMAND 27464 root 20 0 3107m 1.9g 19m S 99.6 6.0 0:37.78 krypton行更改为：

attach.add

如果您在立即窗口中开始看到正确的完整文件路径\文件名，请再次将其更改为：

Debug.Print "C:\users\dmack\my documents\" & tb.DataBodyRange.Cells(Nrow, tb, ListColumns("Manufacturer Name").Index)

Answer 2

这个答案完全正常，能够遍历电子邮件列表并发送所需的Excel文件。它将在5分钟内发送200封电子邮件。正确。为所有有帮助的人欢呼！

Sub BacklogEmail()
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("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 = "Update Required For on 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("Manufacturer Name").Index)
                            lineCounter = lineCounter + 1
                            bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        Else:
                            subjectLine = subjectLine
                            bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        End If

                        Set C = .FindNext(C)
                        Debug.Print vbNewLine
                        Debug.Print emAddress
                        Debug.Print "Subject: " & subjectLine
                        Debug.Print "Body:" & vbNewLine; bodyline
                    Loop While Not C Is Nothing And C.Address <> firstaddress
                End If

                        Run SendMailFunction(emAddress, subjectLine, 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 lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

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

           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
                        Nrow = C.Row - 1
                      If lineCounter = 1 Then

      Set OutMail = OutApp.CreateItem(0)
       On Error Resume Next
        With OutMail

            .To = emAddress
            .Subject = subjectLine
            .Body = "Hello, attached is an excel file that we require you to complete. " & _
                    "This is required by as we must know when parts are going to become obsolete. " & DNL & _
                    "We appriciate your contribution to keeping our databases current. " & DNL & _
                    "Thank you for your timely response."
            .Attachments.Add ":\\\\\" & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ".xlsx"
                            lineCounter = lineCounter + 1

           .Display

      End With
     On Error GoTo 0
        Set OutMail = Nothing


End If
End If
End With
End Function

将相关的Excel文件附加到自动发送电子邮件

2 个答案: