我正在尝试找到一个 Excel 宏,它可以从表中获取标题,然后将某些行复制到电子邮件中。
例如
State | Store | Points
Store1 | VIC | 3201
Store2 | NSW | 1234
Store3 | QLD | 4234
我有以下代码,它允许我选择整个表格,并将其复制到电子邮件中并发送,但我需要它自动提取单行
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email@address"
.CC = ""
.BCC = ""
.Subject = "My Subject here"
.HTMLBody = "<i></i> Hi<br/>" & _
"Please find below a summary of activity.<br/><h3>National Summary</h3>" & _
RangetoHTML(rng) & Signature
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-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 new workbook to past the data in
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 a 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 RangetoHTML
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 we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
我需要的代码是将特定商店的行复制到电子邮件中,以便只有该商店的信息才会出现在邮件中。我该如何对State
列中的每个唯一值执行此操作?
答案1
您正在使用工作表的 创建 HTML 文件UsedRange
。
'Publish the sheet to a 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
设置后,Sheet:=TempWB.Sheets(1).Name
您可以声明另一个范围变量来仅捕获每个商店所需的行,然后将其用作Source:=
。
您的代码无法在我的 Excel 2010 上运行,因此很遗憾我无法验证,但您可以usedRange
使用应该能够在另一个变量中指定范围地址。
例子:
Sub PublishObjectFromFilteredRange()
'An example of applying autofilter to sheet
' and setting range variable = to the autofiltered cells/visible cells
Dim ws As Worksheet
Dim storeID As String
Dim tableRange As Range
Dim filteredRange As Range
Dim pObj As PublishObject
Set ws = Sheets("Sheet1")
'Define the range of the table
Set tableRange = ws.Range(Range("A1").End(xlDown), Range("A1").End(xlToRight))
'Define the Store for which you want to create the report
storeID = "Store 1" '<---- change this as necessary
'Set a filter on the table
tableRange.AutoFilter Field:=1, Criteria1:=storeID
'determine the visible table range
Set filteredRange = tableRange.Cells.SpecialCells(xlCellTypeVisible)
'Create & publish the PublishObject
Set pObj = ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:="C:\Users\david_zemens\Desktop\publish.htm", _
sheet:="Sheet1", _
Source:=filteredRange.Address, _
HtmlType:=xlHtmlStatic)
pObj.Publish True
End Sub