使用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