VBA Excel：将电子表格的提取插入到Outlook电子邮件中

我想能够在Excel中运行一个macros，复制我的Excel电子表格的特定区域，打开一个新的电子邮件，并粘贴区域。到目前为止，我有以下代码：

Sub Macro2() ' 'Macro2 Macro Dim objOutlook As Object Dim objMail As Object Dim TempFilePath As String Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) Dim rng As Range 'Set rng = Selection.SpecialCells(xlCellTypeVisible) Set rng = ActiveSheet.Range("A4:E200").Rows.SpecialCells(xlCellTypeVisible) If rng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected" & _ vbNewLine & "please correct and try again.", vbOKOnly Exit Sub End If With objMail ActiveSheet.Range("$A$3:$P$197").AutoFilter Field:=4, Criteria1:="10" Range("B171:F184,I171:J184").Select Range("I171").Activate Range("B171:F184,I171:J184,M171:N184").Select Range("M171").Activate Selection.Copy .To = "" .CC = "" .Subject = "" .HTMLBody = RangetoHTML(rng) .Display End With Set objOutlook = Nothing Set objMail = Nothing End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2013 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 

这个代码几乎做我想要的，它复制D列中的条件10的filter，并复制并粘贴到一个电子邮件。

但我想要的是代码要通过过滤的单元格（可能是标准1，2，3 …等，而不是一个硬编码的标准，因为它在一分钟），复制并粘贴特定的列到电子邮件。

例如，我想在下面的Band栏中对Queen进行过滤，并将列C（全名）和D（Band）复制并粘贴到电子邮件中。

  ABCD 1 First name: Last name: Full Name: Band: 2 Freddie Mercury Freddie Mercury Queen 3 Brian May Brian May Queen 4 Kurt Cobain Kurt Cobain Nirvana 5 Roger Taylor Roger Taylor Queen 6 Dave Grohl Dave Grohl Nirvana 7 John Deacon John Deacon Queen 8 Kris Novoselic Kris Novoselic Nirvana 

有没有办法做到这一点？ 任何帮助，将不胜感激。

Answer 1

我需要做的是更改Set rng = ActiveSheet.Range("A4:E200").Rows.SpecialCells(xlCellTypeVisible)到我需要的范围，所以Set rng = ActiveSheet.Range("B4:E200, I4:J200, M4:N200").Rows.SpecialCells(xlCellTypeVisible)

这与@Ralph提供的评论类似，但是具有不同的范围。