首先，我对VBA非常陌生。仍在学习，所以我可能会犯一些明显的错误。
我正在尝试使用Excel电子表格构建电子邮件，该电子表格是我从中提取信息以填充电子邮件的“收件人”，“主题”和“正文”的内容。这些将用于销售人员为他们的客户查看信息。我需要每封电子邮件都基于客户，并发送给相应的销售代表。有些客户拥有多条信息，而另一些客户则拥有一些信息，而有些销售人员则拥有重叠的客户。
我发现并一直在尝试编辑的代码（据我所知）是根据电子邮件地址构建电子邮件。因此，我最后收到一封电子邮件，在“收件人”行中有一个销售人员，并且该正文具有专门针对该销售人员的所有客户。同时，主题行仅吸引该电子邮件要显示的一位客户。
任何对此的帮助将是天赐之物。我正试图将4-6小时的工作量减少到1小时以内。
每当我尝试更改代码以使其基于客户而不是电子邮件地址时，我要么最终破坏代码，要么不构建电子邮件，而是以某种方式仅对电子表格应用了过滤器，以针对更改之前发送到电子邮件的信息相同。
我觉得可能需要更多信息，因为我发现这比看起来要复杂得多，但这可能是我对事情的思考过多。我试图将这篇文章限制为仅提供相关信息，但是如果我需要提供更多信息，我当然会。我已经为此动了好几周。
我尝试了多种If And / Then语句来尝试使代码在“客户”列而不是“电子邮件”列中显示，但是我找不到任何有效的组合。我在下面发布的代码已在一定程度上设法使我工作。由于我已经尝试了许多变体，所以我不知道要包括的最佳错误是什么。因此希望这至少不会太混乱。
*编辑：根据我的理解，代码需要在A列中包含一列名称，据此条件是“为此名称使用B列中的地址创建电子邮件”。但是，这似乎是在使用B列中的地址作为条件来创建电子邮件。因此，A中任何与B中的地址匹配的客户行都被投到同一封电子邮件中。我有点需要反过来。列A中每位客户的一封电子邮件发送到列B中列出的电子邮件地址。
Edit2：源信息如下：
+----------------+---------------------+---------+--------------+
| Customer | Email | Subj Ln | Email Body |
+----------------+---------------------+---------+--------------+
| Customer 1 | sales1@address.com | info | info |
| Customer 2 | sales2@address.com | info | info |
| Customer 2 | sales2@address.com | info | info |
| Customer 2 | sales2@address.com | info | info |
| Customer 3 | sales2@address.com | info | info |
| Customer 4 | sales3@address.com | info | info |
| Customer 4 | sales3@address.com | info | info |
| Customer 5 | sales1@address.com | info | info |
| Customer 6 | sales4@address.com | info | info |
+----------------+---------------------+---------+--------------+
因此，代码应查看“客户”列（A列），并查找唯一的实例，然后在“电子邮件”列（B列）中生成具有适当电子邮件地址的电子邮件。每个电子邮件应为单独的电子邮件，并且当电子邮件地址对于客户而言是唯一的时，它将这样做。因此，在上面的示例中，客户6收到一封单独的电子邮件给sales4。电子邮件会生成适当的主题行和电子邮件正文。但是，客户1将生成带有适当的主题和电子邮件正文（针对客户1）的电子邮件，并且还将具有适当的sales1电子邮件地址。但是由于sales1也有客户5，因此客户1的电子邮件中包含客户5的电子邮件正文信息。当我需要Customer 5作为单独的电子邮件时。
Edit3：我在下面添加了以下段落作为注释，因为我不确定哪一种是获得可见性的最佳方法。
我一直在研究代码，并认为我可能已经找到了以前不完全了解的内容。我不确定是否仍会这样做，但我认为我有更好的理解。 -看起来代码正在创建一个过滤器，用于构建电子邮件的正文。它会过滤B列（电子邮件）中的唯一值，并根据此值创建电子邮件。我认为，如果我可以更改该过滤器代码以过滤A列并使用B列构建电子邮件，那么我想我会找到想要的东西。我只是不知道该如何做。
我希望我明白。这让我感到非常困惑和不知所措，但我希望这是有道理的。另外，我希望我的格式正确。
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:AY" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in
column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
.HTMLBody = RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") &
".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Public Function EOMonth(dInput As Date)
LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)
End Function
答案 0 :(得分：3)
我已经这样写了好几次代码-基本模板实际上在我的github
上代码：
Option Explicit
Sub LoopOverData()
Dim STbl As ListObject
Dim LastRow As Long
Dim WB As Workbook
Dim i As Long
Dim WS As Worksheet
Dim tblwsname As String
Set WB = ThisWorkbook
tblwsname = WB.Names("TblWSName").RefersToRange.Value2
Set WS = WB.Sheets(tblwsname)
Set STbl = WS.ListObjects("EmailDataTable")
LastRow = STbl.ListRows.Count
For i = 1 To LastRow
WB.Names("IterationNumber").RefersToRange.Value2 = i
Application.Calculate
Call CreateEmail
Next i
End Sub
Sub CreateEmail()
' This macro is for the pricing confirm e-mail
Dim outApp As New Outlook.Application
Dim OutMail As Object
Dim Attchmnt As String
Dim Signature As String
Dim WB As Workbook
Set WB = ThisWorkbook
Attchmnt = WB.Names("Attachment").RefersToRange.Value2
'We keep the file path for the attachment we're sending in Excel, for easy editing. Look in name manager to find it.
Application.EnableEvents = False
Application.ScreenUpdating = False
' We don't need the screen to flicker while the macro is running - it speeds things up.
Set OutMail = outApp.CreateItem(0)
'Signature = OutMail.Body
On Error Resume Next
With OutMail
.To = WB.Names("to").RefersToRange.Value2
.CC = WB.Names("cc").RefersToRange.Value2
.BCC = WB.Names("bcc").RefersToRange.Value2
.Subject = WB.Names("Subject").RefersToRange.Value2
.Body = WB.Names("Body").RefersToRange.Value2
.display
End With
If Attchmnt = "" Then
Else
OutMail.Attachments.Add Attchmnt
End If
'OutMail.send
'Remove this comment to directly send. Not recommended.
On Error GoTo 0
End Sub
设置：您基本上创建了一个“示例电子邮件”，并使用= index（Range，IndexNum）确定当前正在处理的项目。 IndexNum是一个指向基础索引的命名范围，该范围将随着代码的变化而变化。
因此，随着索引中每个数字的移动，所有公式都会更新为需要编写的新电子邮件。然后，它调用电子邮件生成过程，并创建（但不发送）所需的电子邮件。这是给您一个机会，在发送之前先查看电子邮件。
您需要启用Microsoft Outlook 16.0对象库。
发送丢失的信息可能有一些规则-如果是这种情况，我建议使用一些公式或幂查询进行压缩
答案 1 :(得分：1)
尝试一下，实际上它会生成所需数量的电子邮件。如果可以，我会清除代码
Option Explicit
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:BY" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in Column A
'FieldNum = 2
Columns("A:B").Select
Selection.Copy
ActiveSheet.Paste
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
ActiveSheet.Paste
' FilterRange.Columns(FieldNum).AdvancedFilter _
' Action:=xlFilterCopy, _
' CopyToRange:=Cws.Range("A:B"), _
' CriteriaRange:="", Unique:=True
Columns("A:B").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=1, _
Criteria1:=Cws.Cells(Rnum, 1).Value
FilterRange.AutoFilter Field:=2, _
Criteria1:=Cws.Cells(Rnum, 2).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 2).Value Like "?*@?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
Debug.Print "to: " & .to & " subj: " & .Subject & " body:" & .htmlbody
.to = Cws.Cells(Rnum, 2).Value
.Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
.htmlbody = RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Public Function EOMonth(dInput As Date)
LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)
End Function
答案 2 :(得分：1)
我这样使用，首先，您需要将文本转换为表并将其命名为CustomersTbl或使用
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4))
代替
Set rng = ws.Range("CustomersTbl")
这是一个代码
Sub Send_Row_Or_Rows_2()
' reference Microsoft Scripting Runtime
Dim OutApp As Object, OutMail As Object, dict As Object
Dim tKey(0 To 3, 0 To 1) As Variant
Dim rng As Range
Dim ws As Worksheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False ' speedup Application, disable events
.ScreenUpdating = False ' prevent flashing, disable screen
End With
Set ws = ThisWorkbook.Worksheets("Sheet1") ' set shortest variable for worksheet
Set dict = CreateObject("Scripting.Dictionary") ' set object for unique values
Set rng = ws.Range("CustomersTbl") ' get range to variable
'LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
'Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4)) 'get range to variable
For Each cRow In rng ' create unique dictionary
i = i + 1 ' increment
strCustomer = rng(i, 1)
strEmail = rng(i, 2)
strSubj = rng(i, 3)
strBody = rng(i, 4)
If dict.Exists(strCustomer) Then ' if dublicate
Dim tempArr() As Variant
tempArr() = dict(strCustomer)
If UBound(tempArr, 2) > 0 Then ' if not nothing
If Not IsEmpty(tempArr(0, 1)) Then ' if second element empty
sCount = UBound(tempArr, 2) + 1
Else
sCount = UBound(tempArr, 2) ' as is empty array
End If
End If
ReDim Preserve tempArr(0 To 3, 0 To sCount) ' redim array to next array size
tempArr(0, sCount) = strCustomer 'fill array element
tempArr(1, sCount) = strEmail 'fill array element
tempArr(2, sCount) = strSubj 'fill array element
tempArr(3, sCount) = strBody 'fill array element
dict(strCustomer) = tempArr ' put array to dictionary by unique name
Else
tKey(0, 0) = strCustomer 'fill array element
tKey(1, 0) = strEmail 'fill array element
tKey(2, 0) = strSubj 'fill array element
tKey(3, 0) = strBody 'fill array element
dict.Add strCustomer, tKey ' create unique name
End If
Next cRow ' loop next row
' now dict contains only unique elements, lets loop throught them
For Each UniqueCustomer In dict ' for each unique element
countEmails = UBound(dict(UniqueCustomer), 2) ' count emails of unique group
For i = 0 To countEmails ' loop each email in group
strCustomer = dict(UniqueCustomer)(0, i)
strEmail = dict(UniqueCustomer)(1, i)
strSubj = dict(UniqueCustomer)(2, i)
strBody = dict(UniqueCustomer)(3, i)
If Not IsEmpty(strCustomer) Then ' if element not empty create email
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strEmail
.Subject = strSubj
.HTMLBody = strBody
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
Else
GoTo sNext
End If
Stop
sNext:
Next I ' next email
Next UniqueCustomer 'next unique
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
答案 3 :(得分：1)
如果我的理解正确，您希望基于“客户”和“电子邮件地址”的唯一组合发送电子邮件，并为每个唯一的组合获取相应的主题行和电子邮件正文。因此，在上面的示例中，我假设既然customer2和Customer4是重复的，那么您只想为每个客户发送一封电子邮件，并使用在第一次出现Cutomer2或4时发现的相应主题行和电子邮件正文。
如果我的假设正确，那么下面的代码就可以完成任务。请注意解释每个步骤的注释。
编辑：我忘了提起使用定界符的做法是冒险的，因为该定界符可能存在于数据中的某个位置，并且用该定界符进行拆分会抛出结果。因此，更好的方法（我相信也更干净）如下：
Option Explicit
Public Sub SendEmails()
Dim objDict As Object
Dim objWB As Workbook
Dim objWS As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant, arryTemp As Variant
Application.ScreenUpdating = False
Set objWB = Workbooks("SomeWBName")
Set objWS = objWB.Worksheets("SomeWSName")
lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = objWS.Range("A2:D" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set objDict = CreateObject("Scripting.Dictionary") 'set the dicitonary object
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
'delimiter to form a unique Key
If Not objDict.Exists(varKey) Then
objDict(varKey) = Array(arryEmailData(i, 2), _
arryEmailData(i, 3), _
arryEmailData(i, 4))
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item which is an array
'created in the loop above
On Error GoTo cleanup
For Each varKey In objDict.Keys
arryTemp = objDict.Item(varKey)
Set objOutlookEmail = objOutlookApp.CreateItem(0)
With objOutlookEmail
.To = arryTemp(0)
.Subject = arryTemp(1)
.Body = arryTemp(2)
.Send
End With
Set objOutlookEmail = Nothing
arryTemp = Empty
Next
MsgBox "All Emails have been sent", vbInformation
cleanup:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
原始帖子：
Option Explicit
Public Sub SendEmails()
Dim objDict As Object
Dim objWB As Workbook
Dim objWS As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant, arryTemp As Variant
Application.ScreenUpdating = False
Set objWB = Workbooks("SomeWBName")
Set objWS = objWB.Worksheets("SomeWSName")
lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = objWS.Range("A2:D" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set objDict = CreateObject("Scripting.Dictionary") 'set the dicitonary object
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
'delimiter to form a unique Key
If Not objDict.Exists(varKey) Then 'If the key doesn't already exist, then concatenate
'the corresponding Email Address, subject line,
'and email body using
''|' as a delimiter
objDict(varKey) = Join(Array(arryEmailData(i, 2), _
arryEmailData(i, 3), _
arryEmailData(i, 4)), "|")
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item
'split the item into a 3 element array using '|' delimiter that
'was originally used to concatenate the item in the loop above
On Error GoTo cleanup
For Each varKey In objDict.Keys
arryTemp = Split(objDict.Item, "|")
Set objOutlookEmail = objOutlookApp.CreateItem(0)
With objOutlookEmail
.To = arryTemp(0)
.Subject = arryTemp(1)
.Body = arryTemp(2)
.Send
End With
Set objOutlookEmail = Nothing
Next
MsgBox "All Emails have been sent", vbInformation
cleanup:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub