循环添加比预期更多的附件
Loop adding more attachments than intended
此脚本为客户创建带有发票的电子邮件。它通过列表按客户名称排序，然后添加相应的发票。
脚本正在为每个客户添加正确的发票。
我的问题是它还附上了以前客户的发票。基本上就是积累加法。
我使用了此处显示的代码：Sending multiple attachments from excel sheet with VBA
'Option Explicit
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, "C").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, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) '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:=3, 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("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_CC = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_BCC = ws.Range("Q" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_Sub = ws.Range("S" & 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 Signature As String
Dim rng As Range
Dim lRow As Long, lCol As Long
Dim StrBody As String
'Select the signature to use
SigString = Environ("appdata") & _
"\Microsoft\Signatures\" & Cells(2, 7).Text & ".htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
' 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:M" & Range("A8:M8").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
For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & "<br>" & Signature
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
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
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
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
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
这是我创建 For To 的地方。在此之前，脚本对每个客户名称进行排序：
'Create email
With OutMail
.Subject = Email_Sub & "- " & Subject & Date
.To = Email_Addr
.CC = Email_CC
.Bcc = Email_BCC
.Importance = 2
For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & "<br>" & Signature
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
@Wizhi 发布更正
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, "C").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, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) '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:=3, 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("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_CC = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_BCC = ws.Range("Q" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_Sub = ws.Range("S" & 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:M" & Range("A8:M8").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, "D"), ws.Range(ws.Cells(9, "D"), ws.Cells(ws.Cells(Rows.Count, "D").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible) 'loop only visible data (attachment column) from the filtering
CountVisible = ws.AutoFilter.Range.Columns(4).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("D" & 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, 4).Value & ".pdf"
Next attach_cl
End If
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
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
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
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
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
“累积”的原因是您总是遍历附件列中的所有单元格。
因此，您按客户名称过滤数据，并且仅通过过滤显示可见单元格。
但是 For i 循环将遍历从第 9 行到 D 列最后一行的 所有 个单元格，无论它们是否被过滤。
因此，当您想要获取附件文件时，您只想循环遍历特定客户端的过滤行。我使用了 For each 循环并将范围设置为仅可见单元格。它应该可以解决问题:)
使用 for each 循环的一些技巧。要获取循环的当前单元格位置，我使用：
- 对于循环中的当前行：
attach_cl.row
- 对于循环中的当前列：
attach_cl.column
更改此部分：
For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i
为此：
Dim CountVisible As Long
Dim attach_cl As Range, attach_range As Range
Set attach_range = ws.Range(ws.Cells(9, "D"), ws.Range(ws.Cells(9, "D"), ws.Cells(ws.Cells(Rows.Count, "D").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible) 'loop only visible data (attachment column) from the filtering
CountVisible = ws.AutoFilter.Range.Columns(4).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("D" & 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, 4).Value & ".pdf"
Next attach_cl
End If
我的设置：
ExcelSheet:
文件夹中的文件：
此脚本为客户创建带有发票的电子邮件。它通过列表按客户名称排序，然后添加相应的发票。
脚本正在为每个客户添加正确的发票。
我的问题是它还附上了以前客户的发票。基本上就是积累加法。
我使用了此处显示的代码：Sending multiple attachments from excel sheet with VBA
'Option Explicit
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, "C").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, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) '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:=3, 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("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_CC = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_BCC = ws.Range("Q" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_Sub = ws.Range("S" & 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 Signature As String
Dim rng As Range
Dim lRow As Long, lCol As Long
Dim StrBody As String
'Select the signature to use
SigString = Environ("appdata") & _
"\Microsoft\Signatures\" & Cells(2, 7).Text & ".htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
' 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:M" & Range("A8:M8").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
For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & "<br>" & Signature
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
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
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
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
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
这是我创建 For To 的地方。在此之前，脚本对每个客户名称进行排序：
'Create email
With OutMail
.Subject = Email_Sub & "- " & Subject & Date
.To = Email_Addr
.CC = Email_CC
.Bcc = Email_BCC
.Importance = 2
For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & "<br>" & Signature
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
@Wizhi 发布更正
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, "C").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, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) '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:=3, 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("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_CC = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_BCC = ws.Range("Q" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
Email_Sub = ws.Range("S" & 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:M" & Range("A8:M8").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, "D"), ws.Range(ws.Cells(9, "D"), ws.Cells(ws.Cells(Rows.Count, "D").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible) 'loop only visible data (attachment column) from the filtering
CountVisible = ws.AutoFilter.Range.Columns(4).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("D" & 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, 4).Value & ".pdf"
Next attach_cl
End If
.HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
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
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
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
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
“累积”的原因是您总是遍历附件列中的所有单元格。
因此，您按客户名称过滤数据，并且仅通过过滤显示可见单元格。
但是 For i 循环将遍历从第 9 行到 D 列最后一行的 所有 个单元格，无论它们是否被过滤。
因此，当您想要获取附件文件时，您只想循环遍历特定客户端的过滤行。我使用了 For each 循环并将范围设置为仅可见单元格。它应该可以解决问题:)
使用 for each 循环的一些技巧。要获取循环的当前单元格位置，我使用：
- 对于循环中的当前行：
attach_cl.row - 对于循环中的当前列：
attach_cl.column
更改此部分：
For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i
为此：
Dim CountVisible As Long
Dim attach_cl As Range, attach_range As Range
Set attach_range = ws.Range(ws.Cells(9, "D"), ws.Range(ws.Cells(9, "D"), ws.Cells(ws.Cells(Rows.Count, "D").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible) 'loop only visible data (attachment column) from the filtering
CountVisible = ws.AutoFilter.Range.Columns(4).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("D" & 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, 4).Value & ".pdf"
Next attach_cl
End If
我的设置：
ExcelSheet:
文件夹中的文件：