VBA для отправки электронных писем с диапазоном

Question

Я пытаюсь создать VBA, которая отправляет электронные письма с определенным диапазоном, скопированным в тело.

Если значения в столбце I совпадают, скопируйте ячейки A в H

Повторите этодля каждого региона

Любая помощь будет принята с благодарностью!

Это то, что удалось придумать для начала:

Sub Email()


    Dim currentCentre As String
    Dim cell As Range



    lastrow = Range("A65536").End(xlUp).row

    For Each cell In Range("A2:I" & lastrow)

    If cell.Offset(0, 8).Value = cell.Offset(1, 8).Value Then
    Call prepMail


    End If

    Next
End Sub

Answer 1

Ниже приведены Function для создания таблицы HTML и Sub, которая вызывает ее и генерирует электронную почту

Public Function GenerateHTMLTable(srcData As Range, RegionSelector As String, Optional FirstRowAsHeaders As Boolean = True) As String
    Dim InputData As Variant, HeaderData As Variant
    Dim HTMLTable As String
    Dim i As Long

    ' Declare constants of table element
    Const HTMLTableHeader As String = "<table>"
    Const HTMLTableFooter As String = "</table>"

    ' Update with your sheet reference
    If FirstRowAsHeaders = True Then
        HeaderData = Application.Transpose(Application.Transpose(srcData.Rows(1).Value2))
        InputData = Range(srcData.Rows(2), srcData.Rows(srcData.Rows.Count)).Value2
        ' Add Headers to table
        HTMLTable = "<tr><th>" & Join(HeaderData, "</th><th>") & "</th></tr>"
    Else
        InputData = srcData.Value2
    End If

    ' Loop through each row of data and add selected region to table output
    For i = LBound(InputData, 1) To UBound(InputData, 1)
        ' Test Region against chosen option
        If InputData(i, 9) = RegionSelector Then
            ' Add row to table for output in email
            HTMLTable = HTMLTable & "<tr><td>" & Join(Application.Index(InputData, i, 0), "</td><td>") & "</td></tr>"
        End If
    Next i

    GenerateHTMLTable = HTMLTableHeader & HTMLTable & HTMLTableFooter
End Function

---

Sub testDemo()
    Dim outlookApp As Object
    Dim objMail As Object
    Dim Region
    Dim rng As Range

    ' Create email
    Set outlookApp = CreateObject("Outlook.Application")

    ' Update with your sheet reference
    With Sheet1
        Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
    End With

    For Each Region In Array("Central", "UK & IE")
        With outlookApp.CreateItem(0)
            ' Add table to Email body
            .HTMLBody = GenerateHTMLTable(rng, CStr(Region), True)
            ' Display created email
            .Display
        End With
    Next Region
End Sub

Вывод:

Вы также можете пойти дальше, отредактировав функцию добавления пользовательского css в таблицу