我目前正試圖弄清楚如何制作一個可以執行以下操作的作業簿：
- 向串列中的每個用戶發送電子郵件（MailInfo - sheet1 - 有兩列。A = 用戶，B = 電子郵件地址
- 附加來自四張作業表的行，行僅與他們相關（列 A：H）（發送電子郵件的用戶在作業表 1 的 A 列中，它們列在其他 4 個作業表的 H 列中。目前只有 4 個有范圍的作業表）
我想要完成的是代碼回圈遍歷第 1 表中的代理串列，然后將表格添加到電子郵件正文中，其中僅包含與它們相關的行。
我的挑戰是，我查看了 Ron de Bruin 檔案，我能夠創建包含完整范圍/表格的電子郵件，但我認為它們不適合我的想法。當我把這些東西拼湊在一起時，我想我把它復雜化了。我提供了下面的代碼作為參考。目前它只會為每個用戶打開一封包含所有完整表格的電子郵件。
如果有人能給我一些指點或幫助我，那將對我有很大幫助。
我能夠訪問的當前代碼如下（來自 Ron de Bruin 的檔案），它允許我為 EmailList 1（我將其重命名為 MailInfo）中的每一行打開電子郵件，并且必須添加 B 列以添加郵件地址。但是，我需要找出代碼來啟用對 MailInfo 中 A 列中每個用戶的范圍內值的過濾。
Sub Send_Row_Or_Rows_1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim rng1 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
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("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in 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
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'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
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = Sheets("SampleTable1").Range("A1:H10").SpecialCells(xlCellTypeVisible)
Set rng1 = Sheets("SampleTable2").Range("A1:H10").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.createitem(0)
On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "Test mail"
.HTMLBody = RangetoHTML(rng) & "<br>" & RangetoHTML(rng1)
.display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
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)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
uj5u.com熱心網友回復：
對于每個用戶，將 4 個作業表中的過濾資料合并到 1 個臨時作業表上，然后使用RangeToHtml.
Option Explicit
Sub Send_Row_Or_Rows_1()
Dim wb As Workbook
Dim wsInfo As Worksheet, ws As Worksheet, wsTmp As Worksheet
Dim i As Long, lastrow As Long
Set wb = ThisWorkbook
' sheets to copy
Dim data(3) As Worksheet
Set data(0) = wb.Sheets("SampleTable1")
Set data(1) = wb.Sheets("SampleTable2")
Set data(2) = wb.Sheets("SampleTable3")
Set data(3) = wb.Sheets("SampleTable4")
' add a temporary sheet
Application.DisplayAlerts = False
For Each ws In Sheets
If ws.name = "~tmp" Then ws.Delete
Next
Set wsTmp = Sheets.Add
wsTmp.name = "~tmp"
Application.DisplayAlerts = True
Dim rngCopy As Range
Dim sName As String, sAddr As String
Dim n As Long, k As Long, r As Long
' outlook
Dim appOut As Object, OutMail As Object
Set appOut = CreateObject("Outlook.Application")
' scan users
Set wsInfo = wb.Sheets("Mail Info")
With wsInfo
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
' for each user
For i = 2 To lastrow
sName = Trim(.Cells(i, "A"))
sAddr = Trim(.Cells(i, "B"))
r = 1
wsTmp.Cells.Clear
' consolidate each sheet on tmp sheet
For k = 0 To UBound(data)
Set ws = data(k)
' filter on name in col H 8
With ws.UsedRange
.AutoFilter
.AutoFilter 8, sName ' col H
Set rngCopy = .SpecialCells(xlCellTypeVisible)
rngCopy.Copy wsTmp.Cells(r, 1)
If r > 1 Then wsTmp.Rows(r).Delete ' leave 1 header
r = wsTmp.Cells(ws.Rows.Count, "A").End(xlUp).Row 2 ' leave blank line
.AutoFilter
End With
Next
' email sheet
If r > 1 Then
Set OutMail = appOut.createitem(0)
With OutMail
.To = sAddr
.Subject = "Test Mail to " & sName
.HTMLBody = RangetoHTML(wsTmp.UsedRange)
.display 'Or use Send
End With
Set OutMail = Nothing
n = n 1
End If
Next
End With
Application.DisplayAlerts = False
'ws.Sheets("~tmp").Delete
Application.DisplayAlerts = True
MsgBox n & " emails sent", vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/377348.html
上一篇：回圈遍歷合并單元格下的相鄰單元格