Автоматизированная рассылка писем в Outlook

На днях написал макрос для автоматизации рассылки писем в Outlook. Дарю его всем желающим))

Всем привет.

Несколько лет назад я начал учить VBA для написания макросов в Excel и автоматизации своей работы. Мне это очень понравилось, потому что время на отчетность сократилось в разы, если не на порядок)) Раньше я тратил на регулярные отчеты 5-6 дней в месяц, после автоматизации - несколько часов. Очень приятный бонус - сокращение рутинных действий и освобождение времени для более полезных задач.

На днях написал макрос для автоматизации рассылки писем в Outlook.

Адресаты получат письмо с темой "Подтверждение затрат" с текстом "***** , добрый день! Прошу подтвердить затраты в размере xxx рублей."

Данные вносятся в таблицу Excel. E-mail адреса и имена остаются неизменными, остальное меняется руками или подтягивается формулами. Опять же, можно написать макрос, который будет автоматически подставлять значения из других файлов. Сколько будет строк - не имеет значения, нажимаем кнопку и за минуту отправится сотня писем. Но думаю, если вы будете отправлять письма незнакомым адресатам, быстро улетите в спам. Если у вас в работе возникает необходимость рассылать однотипные письма, файл будет полезен. Ссылка на файл:

docs.google.com

Рассылка по e-mail адресам.xlsm

Наверняка Excel заблокирует у вас выполнение макросов в целях безопасности в скачанном файле. У вас есть 3 варианта: 1) забить и работать по привычке; 2) довериться мне и воспользоваться инструкцией по разблокированию файла: https://support.microsoft.com/ru-ru/topic/%D0%BF%D0%BE%D1%82%D0%B5%D0%BD%D1%86%D0%B8%D0%B0%D0%BB%D1%8C%D0%BD%D0%BE-%D0%BE%D0%BF%D0%B0%D1%81%D0%BD%D1%8B%D0%B9-%D0%BC%D0%B0%D0%BA%D1%80%D0%BE%D1%81-%D0%B7%D0%B0%D0%B1%D0%BB%D0%BE%D0%BA%D0%B8%D1%80%D0%BE%D0%B2%D0%B0%D0%BD-0952faa0-37e7-4316-b61d-5b5ed6024216 (до чего же уродливая ссылка); 3) самостоятельно вставить в ваш файл макрос, код которого вставлю ниже.

Sub SendEmails()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim rngEmails As Range
    Dim cell As Range
    Dim i As Long
    Dim lg_Last_Row As Long
    
    Set OutlookApp = CreateObject("Outlook.Application")    
    lg_Last_Row = Last_Row(1, ActiveSheet)        
    For i = 5 To lg_Last_Row
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = ActiveSheet.Cells(i, 1).Value
            .Subject = ActiveSheet.Cells(i, 3).Value
            .Body = ActiveSheet.Cells(i, 2).Value & ActiveSheet.Cells(5, 6).Value & vbLf & ActiveSheet.Cells(6, 6).Value & _
                ActiveSheet.Cells(i, 4).Value & ActiveSheet.Cells(i, 5).Value
            .Send
        End With
        
        Set OutlookMail = Nothing
    Next i
    Set OutlookApp = Nothing
End Sub

Function Last_Row(lg_Col As Long, ws_Sheet As Worksheet) As Long
    Last_Row = ws_Sheet.Cells(Rows.Count, lg_Col).End(xlUp).Row
End Function

Если нужна будет помощь по адаптации макроса под ваши задачи или необходимость в автоматизации других задач, можете написать мне в телегу: @FMCG_smart_sales.