ITСooky

Нетипичная задача но бывает — надо разослать ста пользователям их сто новых пароль, и как, руками что ли? Если есть офисный пакет с Excel и Outlook на Windows (у меня вот нет) то можно это сделать из таблицы Excel — почти что легко и удобно!

Для начала надо в Excel включить Macros и добавить в ribben вкладку Developer — сами найдите как, вот картинка про Macros

Эх пока был Windows не сделал скриншот вкладки Developer там слева есть иконка про Macros, жмем её и добавляем макрос чтобы было вот так

Код макроса:

Sub Create_Mail_From_List()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
Dim strbody As String
For Each cell In Worksheets("Text").Range("E10:E12")
    strbody = strbody & cell.Value & vbNewLine
Next
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Worksheets("Data").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Worksheets("Data").Cells(cell.Row, "D").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = Worksheets("Text").Range("E6") & " " & Worksheets("Data").Cells(cell.Row, "C").Value & " " & Worksheets("Text").Range("G6")
               .Body = Worksheets("Text").Range("E7") & " " & Worksheets("Data").Cells(cell.Row, "C").Value & " " & Worksheets("Text").Range("G7") & vbNewLine & Worksheets("Text").Range("E8") & vbNewLine & Worksheets("Text").Range("E9") & " " & Worksheets("Data").Cells(cell.Row, "E").Value & " " & Worksheets("Text").Range("G9") & vbNewLine & strbody

                'You can also add files like this:
                '.Attachments.Add ("C:\test.txt")
                .Send  'Or use Display.
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

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

Далее делаем вкладки, важно как они называются и в каких ячейках что стоит

Первая вкладка Texto

Здесь в опредленных местах(надо их придерживаться) вставлен текст, который будет вставляться в письмо!

Вторая вкладка Data

Самая главная вкладка, этой эксель таблицы — сюуда vlook’апится информация из других вкладок и как выясняется Macros не умеет работать с формулами в таблице — не может взять результат!

В столбе B берем ID из столбца A и ищем во вкладке Contacts почту.

=VLOOKUP(A1; $Contacts.$A:$E;2;0)

ВАЖНО: VLOOKUP умеет искать только слева на право. Берет то что слева и ищет в том что с права

В столбе C берем ID из столбца A и ищем во вкладке Contacts имя фамилию.

=VLOOKUP(A1; $Contacts.$A:$E;3;0)

В столбе E берем ID из столбца A и ищем во вкладке Word_List слово.

=VLOOKUP(A1; $Word_List.$A:$B;2;0)

В столбце D если стоит yes макрос отправляет письмо, если не стоит то не отправлеят

Третья вкладка Contacs

Здесь данные о контактах

Третья вкладка Word_List

Здесь ID и слова

Как заставить VBA Macros работать с VLOOKUP в таблице
Пока никак, но есть позорный трюк, который все таки позволяет свершитсья задуманному!
Во вкладке Data надо скопировать всю информацию и тут же вствить её как значения, чтобы пропали формулы!

После этого во вкладке Developers надо нажать вторую иконку слева и запустить макрос. Результат работы на реальном скриншоте в начале статьи(да это реальный скриншот)

Рубрика IT Рецепты

---