将相关的excel文件附加到自动电子邮件
我已经编写了代码，以制造商名称将我的数据导出到为制造商命名的新书中。
现在我已经调整了一个电子邮件macros，以自动发送给制造商。
我希望它自动从我的文档附加我的文件
这就是我所拥有的东西，但它什么都不重视。
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 将您的attach.add行更改为：
Debug.Print "C:\users\dmack\my documents\" & tb.DataBodyRange.Cells(Nrow, tb, ListColumns("Manufacturer Name").Index)
如果您在即时窗口中看到正确的完整文件path\文件名，则再次更改为：
.Attachments.Add "C:\users\dmack\my documents\" & tb.DataBodyRange.Cells(Nrow, tb, ListColumns("Manufacturer Name").Index)
inheritance人答案充分工作，并能够循环通过电子邮件列表，并发送所需的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