【发布时间】：2017-03-29 14:43:04
【问题描述】：
我正在使用从 Ron de Bruin 的网站复制的一些代码（真棒，顺便说一句），但遇到了障碍。
生成的电子邮件只会将标题粘贴到completedTasks 范围内。
它将正确地将Summary 和incompletedTasks 范围粘贴到电子邮件正文中。
如果我删除所有处理 incompletedTasks 的代码，那么它将正确地将 Summary 和 completedTasks HTML 粘贴到电子邮件正文中。
提前感谢您的帮助。
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Sub Monthly_Close_Daily_Report()
'
'
Dim yearMonth As String
Dim closeDay As String
Dim currTime As String
Dim summaryRange As Range
Dim completedTasks As Range
Dim incompleteTasks As Range
Dim emailRng As Range, cl As Range
Dim sTo As String
Application.ScreenUpdating = False
Sheets("Inputs").Select
'Check to make sure there are no errors, then proceed
If Not IsError(Sheets("Inputs").Range("B12")) Then
If Sheets("Inputs").Range("B12") = "Yes" Then
'Store the YY-MM as a variable
Sheets("Inputs").Select
yearMonth = Range("B4").Value
'Store the MM/DD/YYYY as a variable
Sheets("Inputs").Select
closeDay = Range("B5").Value
'Store the current time as a variable
Sheets("Inputs").Select
currTime = Format(Now(), "h:mmAM/PM")
'Unfilter the Task Listing tab
Sheets("Task Listing").Select
Activesheet.ShowAllData
'Refresh the table with new Sharepoint data
ActiveWorkbook.Connections("SharePoint").Refresh
'Create a new email with the Email Listing tab in the "To" line
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Determine the email addresses to send to
Set emailRng = Worksheets("Email Listing").Range("B2:B50")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
'Set the Summary range to be copied into the email
Set summaryRange = Sheets("Summary").Range("A1:G11")
summaryRange.Copy
'Filter the Task Listing tab for this month's completed tasks & copy to range
Sheets("Task Listing").Select
ActiveSheet.ListObjects("Close_Tasks").Range.AutoFilter Field:=1, Criteria1:=yearMonth, Operator:=xlFilterValues
ActiveSheet.ListObjects("Close_Tasks").Range.AutoFilter Field:=6, Criteria1 _
:="Completed"
Set completedTasks = Application.Intersect(ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible), Range("A:G"))
'Set completedTasks = Sheets("Task Listing").UsedRange.SpecialCells(xlCellTypeVisible)
Worksheets("Task Listing").ShowAllData
'Filter the Task Listing tab for this month's non-completed tasks & copy to range
ActiveSheet.ListObjects("Close_Tasks").Range.AutoFilter Field:=1, Criteria1:=yearMonth, Operator:=xlFilterValues
ActiveSheet.ListObjects("Close_Tasks").Range.AutoFilter Field:=6, Criteria1:="<>Completed"
Set incompleteTasks = Application.Intersect(ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible), Range("A:G"))
'On Error Resume Next
With OutMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = "Month End Close Status for " & yearMonth & " As Of " & currTime & " on " & closeDay
.HTMLBody = RangetoHTML(summaryRange) & "<br><br><strong>Completed Tasks" & RangetoHTML(completedTasks) & "<br><br><strong>Incomplete Tasks" & RangetoHTML(incompleteTasks)
.Display 'Can also use .Send which will send the email. We want to preview before sending, though.
End With
Set OutMail = Nothing
Set OutApp = Nothing
Else
'If tasks are missing Due Dates, flag those for the user and exit the macro
MsgBox ("There are ""Due Dates"" missing for some tasks. Please correct the issue and run the macro again.")
End If
End If
'Filter the "Task Listing" tab for the current month
Sheets("Task Listing").Select
Range("A2").Select
Selection.AutoFilter
ActiveSheet.ListObjects("Close_Tasks").Range.AutoFilter Field:=1, Criteria1:=yearMonth, Operator:=xlFilterValues
'
End Sub
【问题讨论】：
-
我的解决方案是将所有范围加入一个新工作表中，然后将整个 rng（工作表）作为一个块发送
-
我想到了这一点，但这对我来说似乎很麻烦，特别是因为我有几个文本标题用于我在电子邮件正文中手动添加的范围。
-
复制粘贴并跟踪标题最后一行的最后一行 +=2 范围最后一行 += 范围。行。数数。抱歉没有记住正确的代码
-
您能分享一个您的电子表格示例吗？