我似乎無法讓我的自動電子郵件代碼正常作業。我一直卡在的地方是第一次查找 A 列中的每個唯一值。
基本上，我有一個作業表，例如，一個名為“Dashboard X”的儀表板需要發送到一封電子郵件中的多個電子郵件地址。我在網上為多封單獨的電子郵件找到了很多代碼，但這一切都需要每個獨特的儀表板都是一封大電子郵件。誰能給我一些關于如何修復這個回圈的建議？
Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
' Set Outlook object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' Create email object.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim UItem As Collection
Dim UV As New Collection
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim iCnt As Integer ' Its just a counter.
Dim sMail_ids As String ' To store recipients email ids.
Dim myDataRng As Range
' We'll now set a range.
Set myDataRng = Range("B2", Range("B" & Rows.Count).End(xlUp))
Set rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
'unique value loop
Set UItem = New Collection
On Error Resume Next
For Each rng In rng
UItem.Add CStr(rng), CStr(rng)
Next
On Error GoTo 0
For i = 1 To UItem.Count
Range("D" & i 1) = UItem(i)
Next
' loop for emails
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set rng = Nothing
Set myDataRng = Nothing ' Clear the range.
With objEmail
.To = sMail_ids ' Assign all email ids to the property.
.Subject = "This is a test message"
.Body = "Hi, there. Hope you are doing well."
.Display ' Display outlook message window.
End With
' Clear all objects.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
End Sub
uj5u.com熱心網友回復：
這是你正在嘗試的嗎？（未經測驗）
Dim UItem As New Collection
Dim aCell As Range
Dim itm As Variant
Dim i As Long: i = 1
On Error Resume Next
For Each aCell In Rng
UItem.Add aCell.Value2, CStr(aCell.Value2)
Next aCell
On Error GoTo 0
For Each itm In UItem
Range("D" & i) = itm
i = i 1
Next
uj5u.com熱心網友回復：
電子郵件地址中不應有任何換行符，我會修剪這些值。
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
至
sMail_ids = sMail_ids & ";" & Trim(cell.Offset(1, 0).Value)
重構代碼
這是我將如何撰寫它（注意更改作業表參考DashboardRange()）：
Private Sub CommandButton1_Click()
Dim Addresses As String
Addresses = DashboardEmailList
If DashboardEmailList = "" Then Exit Sub
Const olMailItem = 0
' Set Outlook object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' Create email object.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = Addresses ' Assign all email ids to the property.
.Subject = "This is a test message"
.Body = "Hi, there. Hope you are doing well."
.Display ' Display outlook message window.
End With
' Clear all objects.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
End Sub
Function DashboardRange() As Range
Set DashboardRange = Sheet1.Range("A1").CurrentRegion
End Function
Function DashboardEmailList() As String
If DashboardRange.Rows.Count = 1 Then Exit Function
Dim Data As Variant
Data = DashboardRange.Value
Dim Collection As New Collection
Dim Addresses As String
Dim r As Long
For r = 2 To UBound(Data)
If Trim(Data(r, 1)) <> "" And Trim(Data(r, 2)) <> "" Then
On Error Resume Next
Collection.Add Data(r, 1), Data(r, 1)
If Err.Number = 0 Then
Addresses = Addresses & Trim(Data(r, 1)) & ";"
End If
On Error GoTo 0
End If
Next
Rem Remove extra semi-colon
If Len(Addresses) > 0 Then DashboardEmailList = Left(Addresses, Len(Addresses) - 1)
End Function
請注意我如何將子例程分解為易于測驗的小函式和子例程。
按儀表板分組的電子郵件地址
Private Sub CommandButton1_Click()
Dim DashboardMap As Object
Set DashboardMap = DashboardEmailList
Dim Key As Variant
Const olMailItem = 0
' Set Outlook object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
For Each Key In DashboardMap
Dim Dashboard As String, Addresses As String
' Create email object.
Dashboard = Key
Addresses = DashboardMap(Key)
Debug.Print Dashboard, Addresses
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = Addresses ' Assign all email ids to the property.
.Subject = "This is a test message"
.Body = "Hi, there. Hope you are doing well."
.Display ' Display outlook message window.
End With
Next
' Clear all objects.
Set objEmail = Nothing: Set objOutlook = Nothing
End Sub
Function DashboardRange() As Range
Set DashboardRange = Sheet1.Range("A1").CurrentRegion
End Function
Function DashboardEmailList() As Object
If DashboardRange.Rows.Count = 1 Then Exit Function
Dim Data As Variant
Data = DashboardRange.Value
Dim Dictionary As Object
Set Dictionary = CreateObject("Scripting.Dictionary")
Dim Addresses As String
Dim Key As String, Value
Dim r As Long
For r = 2 To UBound(Data)
If Trim(Data(r, 1)) <> "" And Trim(Data(r, 2)) <> "" Then
Key = Trim(Data(r, 1))
Value = Trim(Data(r, 2))
If Dictionary.Exists(Key) Then
Dictionary(Key) = Dictionary(Key) & ";" & Value
Else
Dictionary.Add Key, Value
End If
End If
Next
Set DashboardEmailList = Dictionary
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/513311.html