如何遍历一个表列以过滤另一个表以通过电子邮件发送每个过滤的表? [英] How to Loop Through A Table Column to Filter Another Table to Send Each Filtered Table By Email?
问题描述
我正在尝试:
- 使用表A中的值(列-人的名字)在单独的表中过滤表B
- 将已过滤的表B复制到电子邮件正文中(外观)
- 将Outlook电子邮件发送到该收件人的电子邮件地址(来自表A)
- 为表A中的下一个人员再次浏览该过程
表A的示例:
Example of Table A:
表B的示例:
Example of Table B:
例如第一次迭代
- 从表A中获取Dave Jones,并为Dave Jones过滤表B.
- 将过滤后的表B复制到新电子邮件的正文中
- 发送给Dave Jones(davejones@davejones.com).
- 返回表A进入下一个条目(在本例中为Anne Smith),然后执行相同的操作.重复直到表A结束.
我编写了用于设置电子邮件的代码,但这占用了整个工作表,并且不进行任何过滤.我无法弄清楚如何将此循环合并到多封电子邮件中:
I made code for setting up an email but this takes the whole worksheet and does not do any filtering. I am unable to work out how to put this loop together for multiple emails:
Sub SendWorkSheet_SENDEMAILS1()
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.name & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
.to = "EMAIL ADDRESS HERE"
.CC = ""
.BCC = ""
.Subject = "Suppliers"
.HTMLBody = "Hi all," & "<br>" & "<br>" & "Please find attached etc. etc." & "<br>" & "<br>" & "Kind regards," & "<br>" & "<br>" & "Sender"
'.Body = ""
.Attachments.Add Wb2.FullName
.Display
'.Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
推荐答案
过去,我多次需要执行您描述的任务,以下是我想出的解决方案.在 https://www.youtube.com/上对Sigma Coding表示感谢观看?v = ZlInSp0-MdU& ab_channel = SigmaCoding 用于提供大量代码–我为自己的特定应用程序添加的Loop和Filter内容.
I’ve had the need to do the task you describe a number of times in the past, and the following was the solution I came up with. Great credit to Sigma Coding at https://www.youtube.com/watch?v=ZlInSp0-MdU&ab_channel=SigmaCoding for providing the bulk of the code – the Loop and Filter stuff I added for my own specific application.
为使以下各项起作用,您需要在VBA中启用几个引用.在VBA编辑器中,选择工具/参考和工具".选中"Microsoft Outlook 16.0对象库"和"Microsoft Word 16.0对象库"框.如果尚未选中它们,您会发现它们按字母顺序列出.
以下代码建议假定以下条件:
The following code suggestion assumes the following:
•管理员列表位于Sheet1上,它们所包含的范围称为"MyRange"
• The Managers’ list is on Sheet1 and the range they are contained in is called "MyRange"
•要过滤的表在Sheet2上,从单元格A1开始
• The table to filter is on Sheet2 and starts from cell A1
此代码对我有用-让我知道如何使用它.
This code works for me – let me know how you go with it.
Option Explicit
Dim Outlook As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutInspect As Outlook.Inspector
Dim EmailTo As String
Dim OutWrdDoc As Word.Document
Dim OutWrdRng As Word.Range
Dim OutWrdTbl As Word.Table
Dim rng As Range, c As Range, MyRange As Range, myFilter As String
Sub TestEmail()
For Each c In Sheet1.Range("MyRange")
myFilter = c.Value
EmailTo = c.Offset(0, 1).Value
Sheet2.Range("A1:E1").AutoFilter Field:=2, Criteria1:="=" & myFilter
'ERROR TRAP
If EmailTo = "" Or Sheet2.Cells.SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then
GoTo Missing:
End If
Set rng = Sheet2.Cells.SpecialCells(xlCellTypeVisible)
On Error Resume Next
Set Outlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set Outlook = New Outlook.Application
End If
Set OutMail = Outlook.CreateItem(olMailItem)
With OutMail
.To = EmailTo
.Subject = "Suppliers"
.Body = "Please find attached etc."
.Display
Set OutInspect = .GetInspector
Set OutWrdDoc = OutInspect.WordEditor
rng.Copy
Set OutWrdRng = OutWrdDoc.Application.ActiveDocument.Content
OutWrdRng.Collapse Direction:=wdCollapseEnd
Set OutWrdRng = OutWrdDoc.Paragraphs.Add
OutWrdRng.InsertBreak
OutWrdRng.PasteExcelTable Linkedtoexcel:=True, wordformatting:=True, RTF:=True
Set OutWrdTbl = OutWrdDoc.Tables(1)
OutWrdTbl.AllowAutoFit = True
OutWrdTbl.AutoFitBehavior (wdAutoFitWindow)
.Send
Application.CutCopyMode = False
Sheet2.AutoFilterMode = False
End With
Missing:
Next c
End Sub
这篇关于如何遍历一个表列以过滤另一个表以通过电子邮件发送每个过滤的表?的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!