Блог

В настоящее время я пытаюсь понять, как создать рабочую книгу, которая может выполнять следующие действия:

• Отправьте электронное письмо каждому пользователю в списке (MailInfo — лист1 — состоит из двух столбцов. A = Пользователи, B = Адреса электронной почты
• Прикрепите строки из четырех листов со строками, относящимися только к ним (столбцы A:H) (Пользователи для электронной почты указаны в столбце A листа 1, а они перечислены в столбце H на остальных 4 листах. В настоящее время всего 4 листа, которые имеют диапазоны)

Я пытаюсь добиться того, чтобы код проходил по списку агентов на листе 1, а затем добавлял таблицы в текст письма только с теми строками, которые имеют к ним отношение.

Моя проблема в том, что я проверил документацию Рона де Брюна, и я могу создавать электронные письма с полными диапазонами/таблицами, но я не думаю, что они работают для того, что я имею в виду. Когда я собираю кусочки воедино, мне кажется, что я все усложняю. Я привел приведенный ниже код в качестве ссылки. На данный момент он просто откроет электронное письмо для каждого пользователя со всеми полными таблицами.

Если бы кто-нибудь мог дать мне несколько советов или помочь мне, это очень помогло бы мне.

Текущий код, до которого я смог добраться, следующий (из документации Рона де Брюна), который позволяет мне открывать электронные письма для каждой строки в списке рассылки 1 (я переименовал его в MailInfo), и мне пришлось добавить столбец B, чтобы добавить адреса электронной почты. Однако мне нужно выяснить код, позволяющий фильтровать значения в диапазонах для каждого пользователя в столбце A в MailInfo.

 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" amp; 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 gt;= 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" amp; _  Worksheets("Mailinfo").Rows.Count), 2, False)  On Error GoTo 0   If mailAddress lt;gt; "" 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) amp; "lt;brgt;" amp; 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") amp; "/" amp; Format(Now, "dd-mm-yy h-mm-ss") amp; ".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  

Для каждого пользователя объедините отфильтрованные данные с 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 gt; 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 gt; 1 Then  Set OutMail = appOut.createitem(0)  With OutMail  .To = sAddr  .Subject = "Test Mail to " amp; 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 amp; " emails sent", vbInformation End Sub