我目前正在开发一个vba excel宏，该宏过滤特定的行(基于一列中的值)，然后从过滤的行中复制特定的列&将它们作为表格粘贴到outlook电子邮件正文中。我希望将表格粘贴在电子邮件正文中的文本之后。然而，似乎表是邮件正文中唯一的东西&我不能把课文摆在桌子前。
非常感谢您关于如何在粘贴表之前在电子邮件正文中显示文本的建议。我的当前位置："OutMail。Body="；我想放在桌子前面的正文"；不起作用。
EDIT 1=根据CDP1802进行调整+向存档功能添加移动行
代码：
Option Explicit Public ws As Worksheet
Public ol As ListObject
Public olRng As Range
Sub CopyTableToEmail()
Dim olCol As Integer, datCol As Integer
Set ws = Sheets("Test1")
Set ol = ws.ListObjects("TbClient")
Set olRng = ol.Range
'remove table filters
ol.ShowAutoFilter = False
'get Valid column
olCol = ol.ListColumns("Valid").Index
'filter table
ol.Range.AutoFilter field:=olCol, Criteria1:="<0", Operator:=xlOr
'select table to copy
Set olRng = ol.Range
'create mail
Call CreateMail
'Change values on Deactivation e-mail sent column
datCol = ol.ListColumns("Deactivation e-mail sent").Index
ol.ListColumns(datCol).DataBodyRange.SpecialCells(xlCellTypeVisible).Value = Range("H1")
'clear table filters
ol.AutoFilter.ShowAllData
'Move rows to the Archive
Call MoveRows
End Sub
Sub CreateMail()
On Error GoTo errHandler
Dim olCol As Integer, rCell As Range, addRng As Range
Dim mailBcc As String, mailCC As String
'Outlook
Dim OutApp As Object, OutInsp As Object, OutMail As Object
'Declare Word Variables
Dim oWrdDoc As Word.Document, oWdEditor As Word.Editors
Dim sText As String
'Range of mail adresses
olCol = ol.ListColumns("Requestor (email)").Index
Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
'get the mail addresses
For Each rCell In addRng
mailBcc = mailBcc & rCell.Value & ";"
mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
Next rCell
' copy table colmns B,J,L
ws.Columns.Hidden = False
ws.Range("A:A,C:I,K:K,M:Z").EntireColumn.Hidden = True
olRng.Copy
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim signature As String
With OutMail
.display ' or send
signature = .body
.cc = mailCC
.Bcc = mailBcc
.Subject = "Openings Tracker"
End With
' Text
sText = "Ladies and gentlemen," & vbCrLf & vbCrLf
'Get the Active Inspector
'Get the document within the inspector
Set OutInsp = OutMail.GetInspector
Set oWrdDoc = OutInsp.WordEditor
With oWrdDoc
.Content.Delete
.Paragraphs.Add.Range.Text = sText
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = signature
End With
ws.Columns.Hidden = False
Application.CutCopyMode = False
exitRoutine:
'clear
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing
Exit Sub
errHandler:
'Open immediate window to see the error
Debug.Print Err.Number, Err.Description
Resume exitRoutine
End Sub
Sub MoveRows()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim O As Long
A = Worksheets("Test1").UsedRange.Rows.Count
B = Worksheets("Archive").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Test1").Range("O1:O" & A)
On Error Resume Next
Application.ScreenUpdating = False
For O = 1 To xRg.Count
If CStr(xRg(O).Value) = "OK" Then
xRg(O).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
xRg(O).EntireRow.Delete
If CStr(xRg(O).Value) = "OK" Then
O = O - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
在word文档中添加一段。
update1-过滤表，在末尾添加签名。
update2-只显示列B J L
update3-添加AciveRows()
Option Explicit
Public ws As Worksheet
Public ol As ListObject
Public olRng As Range
Sub CopyTableToEmail()
Dim olCol As Integer, datCol As Integer
Set ws = Sheets("Test1")
Set ol = ws.ListObjects("tbClient")
Set olRng = ol.Range
'remove table filters
ol.ShowAutoFilter = False
'get Valid column
olCol = ol.ListColumns("Valid").Index
'filter table
ol.Range.AutoFilter field:=olCol, Criteria1:="<0", Operator:=xlOr
'select table to copy
Set olRng = ol.Range
'create mail
Call CreateMail
'clear table filters
ol.AutoFilter.ShowAllData
End Sub
Sub CreateMail()
On Error GoTo errHandler
Dim olCol As Integer, rCell As Range, addRng As Range
Dim mailBcc As String, mailCC As String
' Outlook
Dim OutApp As Object, OutInsp As Object, OutMail As Object
'Declare Word Variables
Dim oWrdDoc As Word.Document, oWdEditor As Word.Editors
Dim sText As String
'Range of mail adresses
olCol = ol.ListColumns("Requestor email").Index
Set addRng = ol.ListColumns(olCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
'get the mail addresses
For Each rCell In addRng
mailBcc = mailBcc & rCell.Value & ";"
mailCC = mailCC & rCell.Offset(0, 1).Value & ";"
Next rCell
' copy table colmns B,J,L
ws.Columns.Hidden = False
ws.Range("A:A,C:I,K:K,M:Z").EntireColumn.Hidden = True
olRng.Copy
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim signature As String
With OutMail
.display ' or send
signature = .body
.cc = mailCC
.Bcc = mailBcc
.Subject = "Generic Subject"
End With
' Text
sText = "The body text I want to put before the table" & vbCrLf & vbCrLf
'Get the Active Inspector
'Get the document within the inspector
Set OutInsp = OutMail.GetInspector
Set oWrdDoc = OutInsp.WordEditor
With oWrdDoc
.Content.Delete
.Paragraphs.Add.Range.Text = sText
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = signature
End With
ws.Columns.Hidden = False
Application.CutCopyMode = False
exitRoutine:
'clear
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing
Exit Sub
errHandler:
'Open immediate window to see the error
Debug.Print Err.Number, Err.Description
Resume exitRoutine
End Sub
Sub ArchiveRows()
Dim ol As ListObject, rng As Range
Dim r As Long, olCol As Long, n As Long
Set ol = Sheets("Test1").ListObjects("tbClient")
olCol = ol.ListColumns("Valid").Index
With ol.DataBodyRange
For r = 1 To .Rows.Count
If UCase(Trim(.Cells(r, olCol).Value)) = "OK" Then
If rng Is Nothing Then
Set rng = .Rows(r)
Else
Set rng = Union(rng, .Rows(r))
End If
End If
Next
End With
If rng Is Nothing Then
n = 0
Else
n = rng.Rows.Count
With Sheets("Archive")
rng.Copy
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
.PasteSpecial xlPasteValues
End With
End With
rng.Rows.Delete
Application.CutCopyMode = False
End If
MsgBox n & " rows moved to Archive and deleted"
End Sub