[英]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.