脚本在 Outlook 新邮件上复制附件
Script is multiplicating attachments on Outlook new message
如标题所述。在另一位用户的帮助下，我设法完成了一个创建带有一个或多个附件的电子邮件的脚本。它是这样工作的。
首先，脚本遍历所有客户名称并选择唯一值。之后，它一个一个地过滤。如果客户 1 有一行，这意味着 outlook 电子邮件将只有一个附件；如果有 2 行，则有两个附件，依此类推。
我目前的问题是 vba 正在增加附件。如果client 1有3行，则添加3次附件，共9次；目标是每行添加一个附件。
你能发现问题吗？
Sub Filtering()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
If Sheets("Hermes").AutoFilterMode Then 'If autofilter exists, then remove filter
Sheets("Hermes").AutoFilterMode = False
End If
'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False 'Remove filter
Dim Critera_Data_Range() 'Range to filter
Dim Unique_Criteria_Data As Object 'Range to filter but with only unique values
Dim Filter_Row As Long
Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary") 'Create dictionary to store unique values
lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column 'Last column in filter range
Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, "A"))) 'Get all the Client names
For Filter_Row = 2 To UBound(Critera_Data_Range, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range))
'Set filter range
For Each Filter_Value In Unique_Criteria_Data.Keys
'Filter through all the unique names in dictionary "Unique_Criteria_Data"
'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name
With MyRangeFilter
.AutoFilter Field:=1, Criteria1:=Filter_Value, Operator:=xlFilterValues
'Filtering the 3rd column and filter the current filter value
End With
ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy
'copy only visible data from the filtering
Application.CutCopyMode = False 'Clear copy selection
Email_Addr = ws.Range("M" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_CC = ws.Range("N" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_BCC = ws.Range("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_Sub = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
' Make all the Dims
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim rng As Range
Dim lRow As Long, lCol As Long
Dim StrBody As String
' Set the abbreviations
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
filePath = ws.Cells(5, 1)
subject = ws.Cells(2, 5)
StrBody = Cells(5, 3) & "<br><br>" & _
Cells(5, 4) & "<br>"
'Select the appropriate range to copy and paste into the body of the email
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Hermes").Range("A8:H" & Range("A8:H8").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection Is Not valid." & _
vbNewLine & "Please correct And try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Create email
With OutMail
.subject = Email_Sub & " - " & subject & Date
.To = Email_Addr
.CC = Email_CC
.Bcc = Email_BCC
.Importance = 2
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
Dim CountVisible As Long
Dim attach_cl As Range, attach_range As Range
Set attach_range = ws.Range(ws.Cells(9, "B"), ws.Range(ws.Cells(9, "B"), ws.Cells(ws.Cells(Rows.Count, "B").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible) 'loop only visible data (attachment column) from the filtering
If Cells(2, 1) = "PO Number" Then
CountVisible = ws.AutoFilter.Range.Columns(3).SpecialCells(xlCellTypeVisible).Cells.Count - 1 'Count the visible cells from filtered data. Subtract 1 due to header. Number 4 is the column to check how many rows exists with data.
If CountVisible = 1 Then 'If only one row with data, then add the single attachment file
.Attachments.Add filePath & "\" & ws.Range("C" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value & ".pdf"
ElseIf CountVisible >= 2 Then 'If more equal or more than 2 files then loop through the visible range and then add the atttachements
For Each attach_cl In attach_range.SpecialCells(xlCellTypeVisible)
Debug.Print attach_cl 'Check which attachment name currently is in the loop
.Attachments.Add filePath & "\" & Cells(attach_cl.Row, 3).Value & ".pdf"
Next attach_cl
End If
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
Else
CountVisible = ws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count - 1 'Count the visible cells from filtered data. Subtract 1 due to header. Number 4 is the column to check how many rows exists with data.
If CountVisible = 1 Then 'If only one row with data, then add the single attachment file
.Attachments.Add filePath & "\" & ws.Range("B" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value & ".pdf"
ElseIf CountVisible >= 2 Then 'If more equal or more than 2 files then loop through the visible range and then add the atttachements
For Each attach_cl In attach_range.SpecialCells(xlCellTypeVisible)
Debug.Print attach_cl 'Check which attachment name currently is in the loop
.Attachments.Add filePath & "\" & Cells(attach_cl.Row, 2).Value & ".pdf"
Next attach_cl
End If
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next Filter_Value
On Error Resume Next
ws.ShowAllData 'Reset filter
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
当您为 Set attach_range = 设置范围时，似乎您在最后一部分中缺少从 "D" 更改为 "B"（即这部分应该更改为 .End(xlUp).Row, "D")))).更改此设置和您的代码对我来说效果很好。
应该是：
Set attach_range = ws.Range(ws.Cells(9, "B"), ws.Range(ws.Cells(9, "B"), ws.Cells(ws.Cells(Rows.Count, "B").End(xlUp).Row, "B"))).SpecialCells(xlCellTypeVisible)
我用 Option Explicit 测试了你的代码。
我建议声明以下变量以使代码更稳定：
Dim Email_Addr As String
Dim Email_CC As String
Dim Email_BCC As String
Dim Email_Sub As String
Dim filePath As String
Dim Subject As String
如标题所述。在另一位用户的帮助下，我设法完成了一个创建带有一个或多个附件的电子邮件的脚本。它是这样工作的。
首先，脚本遍历所有客户名称并选择唯一值。之后，它一个一个地过滤。如果客户 1 有一行，这意味着 outlook 电子邮件将只有一个附件；如果有 2 行，则有两个附件，依此类推。
我目前的问题是 vba 正在增加附件。如果client 1有3行，则添加3次附件，共9次；目标是每行添加一个附件。
你能发现问题吗？
Sub Filtering()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
If Sheets("Hermes").AutoFilterMode Then 'If autofilter exists, then remove filter
Sheets("Hermes").AutoFilterMode = False
End If
'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False 'Remove filter
Dim Critera_Data_Range() 'Range to filter
Dim Unique_Criteria_Data As Object 'Range to filter but with only unique values
Dim Filter_Row As Long
Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary") 'Create dictionary to store unique values
lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column 'Last column in filter range
Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, "A"))) 'Get all the Client names
For Filter_Row = 2 To UBound(Critera_Data_Range, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range))
'Set filter range
For Each Filter_Value In Unique_Criteria_Data.Keys
'Filter through all the unique names in dictionary "Unique_Criteria_Data"
'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name
With MyRangeFilter
.AutoFilter Field:=1, Criteria1:=Filter_Value, Operator:=xlFilterValues
'Filtering the 3rd column and filter the current filter value
End With
ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy
'copy only visible data from the filtering
Application.CutCopyMode = False 'Clear copy selection
Email_Addr = ws.Range("M" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_CC = ws.Range("N" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_BCC = ws.Range("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_Sub = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
' Make all the Dims
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim rng As Range
Dim lRow As Long, lCol As Long
Dim StrBody As String
' Set the abbreviations
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
filePath = ws.Cells(5, 1)
subject = ws.Cells(2, 5)
StrBody = Cells(5, 3) & "<br><br>" & _
Cells(5, 4) & "<br>"
'Select the appropriate range to copy and paste into the body of the email
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Hermes").Range("A8:H" & Range("A8:H8").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection Is Not valid." & _
vbNewLine & "Please correct And try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Create email
With OutMail
.subject = Email_Sub & " - " & subject & Date
.To = Email_Addr
.CC = Email_CC
.Bcc = Email_BCC
.Importance = 2
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
Dim CountVisible As Long
Dim attach_cl As Range, attach_range As Range
Set attach_range = ws.Range(ws.Cells(9, "B"), ws.Range(ws.Cells(9, "B"), ws.Cells(ws.Cells(Rows.Count, "B").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible) 'loop only visible data (attachment column) from the filtering
If Cells(2, 1) = "PO Number" Then
CountVisible = ws.AutoFilter.Range.Columns(3).SpecialCells(xlCellTypeVisible).Cells.Count - 1 'Count the visible cells from filtered data. Subtract 1 due to header. Number 4 is the column to check how many rows exists with data.
If CountVisible = 1 Then 'If only one row with data, then add the single attachment file
.Attachments.Add filePath & "\" & ws.Range("C" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value & ".pdf"
ElseIf CountVisible >= 2 Then 'If more equal or more than 2 files then loop through the visible range and then add the atttachements
For Each attach_cl In attach_range.SpecialCells(xlCellTypeVisible)
Debug.Print attach_cl 'Check which attachment name currently is in the loop
.Attachments.Add filePath & "\" & Cells(attach_cl.Row, 3).Value & ".pdf"
Next attach_cl
End If
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
Else
CountVisible = ws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count - 1 'Count the visible cells from filtered data. Subtract 1 due to header. Number 4 is the column to check how many rows exists with data.
If CountVisible = 1 Then 'If only one row with data, then add the single attachment file
.Attachments.Add filePath & "\" & ws.Range("B" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value & ".pdf"
ElseIf CountVisible >= 2 Then 'If more equal or more than 2 files then loop through the visible range and then add the atttachements
For Each attach_cl In attach_range.SpecialCells(xlCellTypeVisible)
Debug.Print attach_cl 'Check which attachment name currently is in the loop
.Attachments.Add filePath & "\" & Cells(attach_cl.Row, 2).Value & ".pdf"
Next attach_cl
End If
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next Filter_Value
On Error Resume Next
ws.ShowAllData 'Reset filter
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
当您为 Set attach_range = 设置范围时，似乎您在最后一部分中缺少从 "D" 更改为 "B"（即这部分应该更改为 .End(xlUp).Row, "D")))).更改此设置和您的代码对我来说效果很好。
应该是：
Set attach_range = ws.Range(ws.Cells(9, "B"), ws.Range(ws.Cells(9, "B"), ws.Cells(ws.Cells(Rows.Count, "B").End(xlUp).Row, "B"))).SpecialCells(xlCellTypeVisible)
我用 Option Explicit 测试了你的代码。
我建议声明以下变量以使代码更稳定：
Dim Email_Addr As String
Dim Email_CC As String
Dim Email_BCC As String
Dim Email_Sub As String
Dim filePath As String
Dim Subject As String