发送多个RangeToHTML范围的电子邮件
我正在使用从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
看起来你是从同一张表中拉出两个范围，它只是与过滤相同的表。
将input设置为完成设置input为未完成
完成= RangetoHTML（input）//你正在阅读不完整的不完整= RangetoHTML（input）//你正在读不完整的
相反，试试这个
将input设置为已完成htmlBodyBuffer = RangetoHTML（input）
将input设置为不完整.HTMLBody = htmlBodyBuffer＆RangetoHTML（input）
这个解决方法是使用@Asaf的build议来使用“保存”工作表来合并范围，然后将HTML粘贴到电子邮件。
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 placeholderRange As Range Dim emailRng As Range, cl As Range Dim lastRow As Long, x As Long Dim sTo As String Application.ScreenUpdating = False Application.DisplayAlerts = 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 Range("A1").Select Selection.AutoFilter 'Refresh the table with new Sharepoint data ActiveWorkbook.Connections("SharePoint").Refresh 'Create a new email with the Email Listing tab in the "To" line, and Alan and Tim cc'd 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 table for "Completed" and then add it to the placeholder tab to be converted to HTML Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Placeholder" Range("A1").Select ActiveCell.FormulaR1C1 = "Completed Tasks" With Selection.Font .Name = "Arial" .Size = 18 .ThemeColor = xlThemeColorLight1 End With Selection.Font.Bold = True 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" ActiveSheet.UsedRange.Select Selection.SpecialCells(xlCellTypeVisible).Select Selection.Copy Sheets("Placeholder").Select Range("A3").Select ActiveSheet.Paste 'Find the last row of the "Placeholder" sheet lastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Copy the format to the "Incomplete" section header Range("A1").Select Selection.Copy Range("A" & lastRow + 3).Select ActiveSheet.Paste ActiveCell.FormulaR1C1 = "Incomplete Tasks" 'Filter the table for "Incomplete" and then add it to the placeholder tab to be converted to HTML Sheets("Task Listing").Select ActiveSheet.ListObjects("Close_Tasks").Range.AutoFilter Field:=6, Criteria1 _ :="=In Progress", Operator:=xlOr, Criteria2:="=Not Started" ActiveSheet.UsedRange.Select Selection.SpecialCells(xlCellTypeVisible).Select Selection.Copy Sheets("Placeholder").Select 'Find the new last row of the "Placeholder" tab lastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Paste the incomplete tasks to the "Placeholder" tab Range("A" & lastRow + 1).Select ActiveSheet.Paste 'Format the "Placeholder" tab Cells.Select With Selection .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Cells.EntireColumn.AutoFit 'Find the new last row of the "Placeholder" tab lastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Make the entire "Placeholder" sheet the placeholderRange Set placeholderRange = Range("A1:G" & lastRow) '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) .HTMLBody = RangetoHTML(summaryRange) & "<br><br>" & RangetoHTML(placeholderRange) .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 'Delete the Placeholder tab Sheets("Placeholder").Delete '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 Application.ScreenUpdating = True Application.DisplayAlerts = True ' End Sub