使用VBA将两个范围复制到Excel电子邮件中的Outlook电子邮件（大部分代码已经完成）

Question

这是我第一篇文章，所以请好！

我有一个很酷的宏，我用我在网上找到的代码片段（主要来自Excel MVP Ron de Bruin）做了一个很酷的宏。

它所做的是从一个范围复制数据（尚未格式化为表格，因为代码不支持该功能，但可能必须是）并执行VLookup以创建临时工作簿，其中的数据仅与具体人的名字。然后它会引用一张映射表并向这些人发送一封Outlook电子邮件。这非常棒。

现在，当页面上只有一个数据集时，它可以很好地工作。但是，当页面上有两个对象时，我的问题就来了，因为它不包含列标题。

如果您查看我附加的文件图像（http://imgur.com/z7K1EeL），我有北美和欧洲的样本数据，有些名称重叠。我需要将不同的栏目标题结转，因此收到电子邮件的人知道NA数据和欧洲数据之间的差异。

它生成的电子邮件如下所示：（http://imgur.com/Z2qUR06）正如您所看到的，第二个条目没有意义，因为它发生在不同的标题下。

Option Explicit 

    Sub Send_Row_Or_Rows_Attachment_1() 
    'Working in 2000-2013 
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
     Dim OutApp As Object 
     Dim OutMail As Object 
     Dim rng As Range 
     Dim Ash As Worksheet 
     Dim Cws As Worksheet 
     Dim Rcount As Long 
     Dim Rnum As Long 
     Dim FilterRange As Range 
     Dim FieldNum As Integer 
     Dim mailAddress As String 
     Dim NewWB As Workbook 
     Dim TempFilePath As String 
     Dim TempFileName As String 
     Dim FileExtStr As String 
     Dim FileFormatNum As Long 

     On Error GoTo cleanup 
     Set OutApp = CreateObject("Outlook.Application") 

     With Application 
      .EnableEvents = False 
      .ScreenUpdating = False 
     End With 

     'Set filter sheet, you can also use Sheets("MySheet") 
     Set Ash = ActiveSheet 

     'Set filter range and filter column (column with names) 
     Set FilterRange = Ash.Range("A5:H" & Ash.Rows.Count) 
     FieldNum = 1 'Filter column = A because the filter range start in column A 

     'Add a worksheet for the unique list and copy the unique list in A1 
     Set Cws = Worksheets.Add 
     FilterRange.Columns(FieldNum).AdvancedFilter _ 
       Action:=xlFilterCopy, _ 
       CopyToRange:=Cws.Range("A1"), _ 
       CriteriaRange:="", Unique:=True 

     'Count of the unique values + the header cell 
     Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1)) 

     'If there are unique values start the loop 
     If Rcount >= 2 Then 
      For Rnum = 2 To Rcount 

       'Look for the mail address in the MailInfo worksheet 
       mailAddress = "" 
       On Error Resume Next 
       mailAddress = Application.WorksheetFunction. _ 
        VLookup(Cws.Cells(Rnum, 1).Value, _ 
           Worksheets("Mailinfo").Range("A1:B" & _ 
            Worksheets("Mailinfo").Rows.Count), 2, False) 
       On Error GoTo 0 

       If mailAddress <> "" Then 

        'Filter the FilterRange on the FieldNum column 
        FilterRange.AutoFilter Field:=FieldNum, _ 
              Criteria1:=Cws.Cells(Rnum, 1).Value 

        'Copy the visible data in a new workbook 
        With Ash.AutoFilter.Range 
         On Error Resume Next 
         Set rng = .SpecialCells(xlCellTypeVisible) 
         On Error GoTo 0 
        End With 

        Set NewWB = Workbooks.Add(xlWBATWorksheet) 

        rng.Copy 
        With NewWB.Sheets(1) 
         .Cells(1).PasteSpecial Paste:=8 
         .Cells(1).PasteSpecial Paste:=xlPasteValues 
         .Cells(1).PasteSpecial Paste:=xlPasteFormats 
         .Cells(1).Select 
         Application.CutCopyMode = False 
        End With 

        'Create a file name 
        TempFilePath = Environ$("temp") & "\" 
        TempFileName = "Your data of " & Ash.Parent.Name _ 
           & " " & Format(Now, "dd-mmm-yy h-mm-ss") 

        If Val(Application.Version) < 12 Then 
         'You use Excel 97-2003 
         FileExtStr = ".xls": FileFormatNum = -4143 
        Else 
         'You use Excel 2007-2013 
         FileExtStr = ".xlsx": FileFormatNum = 51 
        End If 

        'Save, Mail, Close and Delete the file 
        Set OutMail = OutApp.CreateItem(0) 

        With NewWB 
         .SaveAs TempFilePath & TempFileName _ 
           & FileExtStr, FileFormat:=FileFormatNum 
         On Error Resume Next 
         With OutMail 
          .To = mailAddress 
          .Subject = "Test mail" 
          .Attachments.Add NewWB.FullName 
          .HTMLBody = RangetoHTML(rng) 
          .Display 'Or use Send 
         End With 
         On Error GoTo 0 
         .Close savechanges:=False 
        End With 

        Set OutMail = Nothing 
        Kill TempFilePath & TempFileName & FileExtStr 
       End If 

       'Close AutoFilter 
       Ash.AutoFilterMode = False 

      Next Rnum 
     End If 

     cleanup: 
     Set OutApp = Nothing 
     Application.DisplayAlerts = False 
     Cws.Delete 
     Application.DisplayAlerts = True 

     With Application 
      .EnableEvents = True 
      .ScreenUpdating = True 
     End With 
    End Sub 
    Function RangetoHTML(rng As Range) 
    ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. 
     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 workbook to receive the data. 
     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 an .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 the RangetoHTML subroutine. 
     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. 
     Kill TempFile 

     Set ts = Nothing 
     Set fso = Nothing 
     Set TempWB = Nothing 
    End Function 

Answer 1

后重新阅读的问题，我觉得最简单的方法是阅读下来，原本的工作表，命名遇到的第一次全表复制到一个新的工作簿每次命名表之后，然后从该表中删除所有其他名称。这给我们留下了每个人的工作表，所有原始标题和格式都完好无损，然后我们可以通过电子邮件发送。所以这是我的代码。我没有触及任何电子邮件代码。我相信从原来的代码，人的名字，例如， “Jim”是用来查找电子邮件地址并在该人员易于获取姓名之后命名该表的人员。

Option Explicit 

Const NAME_HEADING As String = "Name" 
' 

Sub Send_Row_Or_Rows_Attachment_1() 
'Working in 2000-2013 
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim rng As Range 
    Dim fullDataSheet As Worksheet 
    Dim tempBook As Workbook 
    Dim Cws As Worksheet 
    Dim mailAddress As String 
    Dim NewWB As Workbook 
    Dim TempFilePath As String 
    Dim TempFileName As String 
    Dim FileExtStr As String 
    Dim FileFormatNum As Long 

    On Error GoTo cleanup 
    Set OutApp = CreateObject("Outlook.Application") 

    With Application 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    'Set filter sheet, you can also use Sheets("MySheet") 
    Set fullDataSheet = ActiveSheet 
    Set tempBook = Workbooks.Add(xlWBATWorksheet) 

    CreateSheets fullDataSheet, tempBook 

    ' Now loop through the sheets in tempBook and email each one 
    For Each Cws In tempBook.Worksheets 
     Set rng = Cws.UsedRange 
     If rng.Row > 2 Then 
      'Look for the mail address in the MailInfo worksheet 
      mailAddress = "" 
      On Error Resume Next 
      mailAddress = Application.WorksheetFunction. _ 
       VLookup(Cws.Name, _ 
          Worksheets("Mailinfo").Range("A1:B" & _ 
           Worksheets("Mailinfo").Rows.Count), 2, False) 
      On Error GoTo 0 

      If mailAddress <> "" Then 
       'Copy the data to a new workbook 
       Set NewWB = Workbooks.Add(xlWBATWorksheet) 

       rng.Copy 

       With NewWB.Sheets(1) 
        .Cells(1).PasteSpecial Paste:=8 
        .Cells(1).PasteSpecial Paste:=xlPasteValues 
        .Cells(1).PasteSpecial Paste:=xlPasteFormats 
        .Cells(1).Select 
        Application.CutCopyMode = False 
       End With 

       'Create a file name 
       TempFilePath = Environ$("temp") & "\" 
       TempFileName = "Your data of " & fullDataSheet.Parent.Name _ 
          & " " & Format(Now, "dd-mmm-yy h-mm-ss") 

       If Val(Application.Version) < 12 Then 
        'You use Excel 97-2003 
        FileExtStr = ".xls": FileFormatNum = -4143 
       Else 
        'You use Excel 2007-2013 
        FileExtStr = ".xlsx": FileFormatNum = 51 
       End If 

       'Save, Mail, Close and Delete the file 
       Set OutMail = OutApp.CreateItem(0) 

       With NewWB 
        .SaveAs TempFilePath & TempFileName _ 
          & FileExtStr, FileFormat:=FileFormatNum 
        On Error Resume Next 
        With OutMail 
         .To = mailAddress 
         .Subject = "Test mail" 
         .Attachments.Add NewWB.FullName 
         .HTMLBody = RangetoHTML(rng) 
         .Display 'Or use Send 
        End With 
        On Error GoTo 0 
        .Close SaveChanges:=False 
       End With 

       Set OutMail = Nothing 
       Kill TempFilePath & TempFileName & FileExtStr 
      End If  ' If mailAddress <> "" 
     End If  ' If rng.Row > 2 
    Next Cws 

cleanup: 
    Set OutApp = Nothing 
    Application.DisplayAlerts = False 
    tempBook.Close SaveChanges:=False 
    Application.DisplayAlerts = True 

    With Application 
     .EnableEvents = True 
     .ScreenUpdating = True 
    End With 

End Sub 
Function RangetoHTML(rng As Range) 
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. 
    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 workbook to receive the data. 
    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 an .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 the RangetoHTML subroutine. 
    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. 
    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 
    Set TempWB = Nothing 
End Function 

Private Sub CreateSheets(ByRef sourceSheet As Worksheet, ByRef newBook As Workbook) 

' Reads down the sourceSheet looking at each name 
' Looks for worksheet in newBook that already has this name 
' If exists, move to next name 
' If doesn't exist, then copies sourceSheet to newBook and 
' then reads down the list deleting rows *not* for the current name 

Dim thisCell As Range 
Dim thisPersonsSheet As Worksheet 
Dim thisName As String 
Dim lastRow As Long 

    lastRow = sourceSheet.UsedRange.Row + sourceSheet.UsedRange.Rows.Count 

    Set thisCell = sourceSheet.Range("A1") 

    Do While thisCell.Row <= lastRow 
     thisName = Trim(thisCell.Value) 
     ' Is this an actual name? 
     If (thisName <> "") And (thisName <> NAME_HEADING) Then 
      ' Has code already seen this name before 
      If Not WorksheetExists(newBook, thisName) Then 
       sourceSheet.Copy After:=newBook.Worksheets(newBook.Worksheets.Count) 
       Set thisPersonsSheet = newBook.Worksheets(newBook.Worksheets.Count) 
       thisPersonsSheet.Name = thisName 
       ' Remove all other names from the sheet 
       DeleteOtherNamesFromSheet thisPersonsSheet 
      End If 
     End If 
     Set thisCell = thisCell.Offset(RowOffset:=1) 
    Loop 

End Sub 

Private Sub DeleteOtherNamesFromSheet(ByRef thisPersonsSheet As Worksheet) 

' Reads down the thisPersonsSheet looking at each name 
' If matches name of the sheet or is NAME_HEADING or blank 
' then leave, else deletes the row 

Dim thisCell As Range 
Dim thisPersonsName As String 
Dim thisName As String 
Dim lastRow As Long 
Dim deleteRowAbove As Boolean 

    lastRow = thisPersonsSheet.UsedRange.Row + thisPersonsSheet.UsedRange.Rows.Count 

    Set thisCell = thisPersonsSheet.Range("A1") 
    deleteRowAbove = False 

    thisPersonsName = thisPersonsSheet.Name 

    Do While thisCell.Row <= (lastRow + 1) 
     If deleteRowAbove Then 
      thisCell.Offset(RowOffset:=-1).EntireRow.Delete 
      deleteRowAbove = False 
     End If 

     thisName = Trim(thisCell.Value) 
     ' Is this an actual name that is *not* this person? 
     If (thisName <> "") And (thisName <> NAME_HEADING) And (thisName <> thisPersonsName) Then 
      deleteRowAbove = True 
     End If 
     Set thisCell = thisCell.Offset(RowOffset:=1) 
    Loop 

End Sub 

Private Function WorksheetExists(ByRef theWorkbook As Workbook, ByRef sheetName As String) As Boolean 

' Returns True if a worksheet named 'sheetName' exists in theWorkbook 

On Error Resume Next ' In case the worksheet does not exist 

Dim wks As Worksheet 
Dim result As Boolean 

    Set wks = theWorkbook.Worksheets(sheetName) 

    If (wks Is Nothing) Then 
     Err.Clear 
     result = False 
    Else 
     result = True 
    End If 

    WorksheetExists = result 

End Function