Отправка писем уникальным людям из колонки - PullRequest
Новая
       9

Отправка писем уникальным людям из колонки

0 голосов
/ 28 января 2020

У меня есть ТАБЛИЦА со списком людей, их именами и столбцом состояния (Y / N). 

Column 1    Column 2    Column 3 
 (Name)      (Email)  (Condition Y/N)

Я хочу отправлять электронные письма всем людям в ТАБЛИЦЕ, чье имя совпадает с уникальным значения (имя) в одном из столбцов на листе 1.

Так что я хочу что-то, что ищет столбец на листе 1 и, возможно, изменяет условие на Y (в столбце 3) в таблице, для всех уникальных имена, найденные в этом столбце (столбец D) на листе 1. (Я могу отфильтровать таблицу в POWER QUERY, чтобы отобразить только строки с условием «Y»).

Когда всплывает одно сообщение (со всеми люди в "Кому",) Я хочу, чтобы Лист 1 или Лист 2 был прикреплен к электронному письму. Это уже сделано.

У меня есть макрос 1, который запускается и генерирует новый лист под названием «Лист 1».

Мой второй макрос работает следующим образом. Он отображает Outlook. Это работает для создания всплывающего окна с приложенным файлом. Я хочу, чтобы в колонку 3 добавлялись только те люди, у которых есть буква "Y". Но столбец D в «Листе 1» содержит список людей, которые не выполняли различные задачи. Теперь используя этот столбец, я хочу изменить Условие на «Y» или «N» в столбце 3 для всех уникальных имен, найденных в столбце D «Листа 1». Обратите внимание, что «Лист 1» будет создаваться каждый раз, когда я запускаю Macro 1. Я думаю об ошибке if (vlookup ......). Как вы думаете, это будет работать? Это лучший способ? Что вы рекомендуете?

Пожалуйста, смотрите код для Macro 2. 

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Attachment code based on: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326
    ' Adapted by Ricardo Diaz ricardodiaz.co
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim newBook As Workbook
    Dim newBookName As String

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table6_2").ListObject

    On Error GoTo Cleanup

    ' Save current file to temp folder (delete first if exists)
    ThisWorkbook.Worksheets("Sheet 1").Copy
    Set newBook = ActiveWorkbook
    newBookName = "AttachedSheet.xlsx"
    On Error Resume Next
    Kill Environ("temp") & newBookName
    On Error GoTo 0
    Application.DisplayAlerts = False
    newBook.SaveAs Environ("temp1") & newBookName
    Application.DisplayAlerts = True

    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter + 1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please comply with your tasks in the attached file " & _
                "and let us know if you have any questions."

        'You can add files also like this
        .Attachments.Add newBook.FullName ' -> Adjust this path

        .Display ' -> Or use Display
    End With

    Set OutMail = Nothing

Cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub
...