这是我在这里的第一篇文章，所以请友善！
我有一个 excel 文件，其中包含一个非常酷的宏，我使用我在网上找到的代码片段（主要来自 Excel MVP Ron de Bruin）制作。
它的作用是从范围（尚未格式化为表格，因为代码不支持，但可能必须这样做）复制数据，并执行 VLookup 以创建临时工作簿，其中包含仅与特定人员姓名相关的数据。然后，它引用映射表并向这些人发送 Outlook 电子邮件。真是太棒了。
现在，当页面上只有一个数据集时，它可以完美运行。但是，当页面上有两个对象时，我的问题就来了，因为它不会继承列标题。
如果您查看我随附的文件图像（https://i.stack.imgur.com/K6LSC.jpg），我有北美和欧洲的示例数据，有些名称重叠。我需要不同的列标题来延续，以便接收电子邮件的人知道 NA 数据和欧洲数据之间的区别。
它生成的电子邮件如下所示：（https://i.stack.imgur.com/0mDHU.jpg）如您所见，第二个条目没有意义，因为它发生在不同的标题下。
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
重新阅读问题后，我认为最简单的方法是阅读原始工作表，每次第一次遇到名称时，将整个工作表复制到新工作簿中，以人命名工作表，然后从该工作表中删除所有其他名称。这给我们留下了每个人的工作表，所有原始标题和格式都完好无损，然后我们可以通过电子邮件发送。所以这是我的代码。我没有碰过任何电子邮件代码。
我相信从原始代码中，人的名字，例如"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