[英]Copying two ranges into an outlook email from excel using VBA (Most of the code already done)
这是我在这里的第一篇文章，所以请保持友好！
我有一个Excel文件，其中包含一个非常酷的宏，我使用在网上找到的代码片段（主要来自Excel MVP Ron de Bruin ）制成了宏。
它的作用是从一定范围内复制数据（由于代码不支持，但尚未将其格式化为表格，但可能必须如此），并执行VLookup来创建临时工作簿，其中的数据仅与特定人员的姓名有关。 然后，它引用映射表并向这些人发送Outlook电子邮件。 太棒了
现在，当页面上只有一个数据集时，它可以完美地工作。 但是，当页面上有两个对象时，我的问题来了，因为它不携带列标题。
如果您查看我在文件中附带的图片（ http://imgur.com/z7K1EeL ），则我会看到北美和欧洲的样本数据，有些名称重叠。 我需要不同的列标题来保留，因此接收电子邮件的人知道NA数据和European Data之间的区别。
它生成的电子邮件如下所示：（ 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
重新阅读问题后，我认为最简单的方法是阅读原始工作表，每次第一次遇到名称时，都要将整个工作表复制到一个新的工作簿中，以该人的名字命名工作表，然后删除所有工作表。该工作表中的其他名称。 这样，我们就可以为每个人保留一个完整的工作表，并且保留所有原始标题和格式，然后我们可以通过电子邮件发送该工作表。 这是我的代码。 我没有触摸任何电子邮件代码。
我相信从原始代码来看，此人的姓名（例如“ 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
使用 VBA 将富文本表格从 Outlook 电子邮件复制到 Excel？
[英]Copying a rich text table from an Outlook email to Excel using VBA?
使用带有两个电子邮件地址的vba将Outlook中的电子邮件主题复制到Excel？
[英]Copy email subject in outlook to excel using vba with two email address?
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.