在Outlook电子邮件中粘贴可变范围

Question

我在Ron de Bruin的网站上使用了“将Excel范围粘贴到Outlook /电子邮件”。我在函数中使用可变范围时遇到问题。

我设置了两个范围（rng1和rng2）和两个相应的功能。我的错误是在此行（45）中，它提取了变量范围：

Set rng1 = Sheets("Sheet2").Range(Cells(6, 8), Cells((NewRowFxn(NewRow) - 1), "N")).SpecialCells(xlCellTypeVisible)

我从第一个范围（rng1）开始，但是它失败了，因此尚未设置rng2的代码。

我如何设置变化范围以找到最后一行数据，然后将其输入到rng1和rgn2公式中？

Sub Macro1()
 Dim rng1 As Range
 Dim rng2 As Range
 Dim OutApp As Object
 Dim OutMail As Object
 Dim sCC As String, sSubj As String, sEmAdd As String
 Dim mail_bodyA As String
 Dim mail_bodyB As String
 Dim mail_bodyC As String
 Dim f_name As String
 Dim fiscalq As String

 '// Change the values of these variables to suit
 sEmAdd = Sheet2.Range("E7")
 sCC = ""
 sSubj = Sheet2.Range("C2")
 mail_bodyA = Sheet1.Range("K2")
 mail_bodyB = Sheet1.Range("K4")
 mail_bodyC = Sheet1.Range("K6")
 f_name = Sheet2.Range("G7")
 fiscalq = Sheet2.Range("D7")
  Set rng1 = Nothing
 On Error Resume Next
 Set rng1 = Sheets("Sheet2").Range(Cells(6, 8), Cells((NewRowFxn(NewRow) - 1), "N")).SpecialCells(xlCellTypeVisible)
 'Set rng1 = Sheets("Sheet2").Range("H6:N7").SpecialCells(xlCellTypeVisible)
 On Error GoTo 0
 With Application
 .EnableEvents = 0
 .ScreenUpdating = 0
 .Calculation = xlCalculationManual
 End With
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)
 On Error Resume Next
 With OutMail
 .To = sEmAdd
 .CC = sCC
 .Subject = sSubj
 .HTMLBody = mail_bodyA & RangetoHTML(rng1)
 .Display '// Change this to .Display if you want to view the email before sending. .Send originally
 End With
 On Error GoTo 0
 With Application
 .EnableEvents = 1
 .Calculation = xlCalculationAutomatic
 End With
 Set OutMail = Nothing: Set OutApp = Nothing
End Sub


Function RangetoHTML(rng1 As Range)
 Dim fso As Object, ts As Object, TempWB As Workbook, TempFile As String
 TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 rng1.Copy
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
 .Cells(1).Select
 Application.CutCopyMode = False
 End With
 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
 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=")
 TempWB.Close 0
 Kill TempFile
 Set ts = Nothing: Set fso = Nothing: Set TempWB = Nothing
End Function


Function NewRowFxn()
 Dim NewRow As Integer
 NewRow = 6
 Do
    DoEvents
    NewRow = NewRow + 1
    Item = Sheet2.Range("N" & NewRow)
 Loop Until Item = ""
 End Function


 Function OldRowFxn()
 Dim OldRow As Integer
 OldRow = 6
    Do
    DoEvents
    OldRow = OldRow + 1
    Itemold = Sheet2.Range("V" & OldRow)
    Loop Until Itemold = ""
 End Function

Answer 1

对于我的各种代码，我这样做：

Dim lRowNew As Integer
lRowNew = Range("N:N").Find(What:="*", Lookin:=xlValues, Lookat:=xlPart, SearchOrder:=xlRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
Set rng1 = Nothing
 On Error Resume Next
 Set rng1 = Sheets("Sheet2").Range(("H6:N" & lRowNew)).SpecialCells(xlCellTypeVisible)
 On Error GoTo 0

而且有效！

我还能够设置另一个lRow（lRowOld）来捕获另一最后一行并将其分配给rng2，并且能够使用这两行并将两个不同的范围粘贴到电子邮件中。