Электронная почта людей на основе диапазона VBA - PullRequest
Новая
       10

Электронная почта людей на основе диапазона VBA

0 голосов
/ 22 февраля 2019

У меня есть следующий набор данных

У меня есть следующий код для отправки электронного письма в каждую строку.Как мне сгруппировать строки и отправить их как 1 электронное письмо, как на картинке

Вот пример письма, которое я собираюсь построить

На данный моменткод проходит по каждой строке и строит и отправляет по электронной почте.Я хочу, чтобы он проверил столбец A на наличие кода и нашел все остальные столбцы с тем же кодом, и создал одно электронное письмо, используя информацию из всех своих столбцов 

    Sub SendIntransitEmail()

    Dim Mail_Object, OutApp As Variant
    Dim eRng1, eRng2, eRng3, rng1, rng2, rng3, rng4, cl As Range
    Dim sTo, sCC, sLoc, sFile1, sFile2, sHeader, sBody As String

    Set rng4 = ThisWorkbook.Worksheets("sheet1").Range("B4")

    Dim intNum As Integer
        intNum = ThisWorkbook.Worksheets("sheet1").Range("B1")


    For i = 5 To intNum
    On Error Resume Next
    Set Mail_Object = CreateObject("Outlook.Application")
    Set OutApp = Mail_Object.CreateItem(0)
        Set rng1 = ThisWorkbook.Worksheets("sheet1").Range("A" & i)
        Set eRng1 = ThisWorkbook.Worksheets("sheet1").Range(Cells(i, 5), Cells(i, 8))
        Set eRng2 = ThisWorkbook.Worksheets("sheet1").Range(Cells(i, 9), Cells(i, 40))
        Set eRng3 = ThisWorkbook.Worksheets("sheet1").Range(Cells(4, 2), Cells(4, 4))
        Set eRng4 = ThisWorkbook.Worksheets("sheet1").Range(Cells(i, 2), Cells(d, 2))
            For Each cl In eRng1
        sTo = sTo & ";" & cl.Value
    Next
    sTo = Mid(sTo, 2)

    For Each cl In eRng2
        sCC = sCC & ";" & cl.Value
    Next

    For Each cl In eRng3
            sDelivery = sDelivery & cl.Value
        Next

        For Each cl In eRng4
            sTrailer = sTrailer & cl.Value
        Next
        For Each cl In eRng5
            sShipper = sShipper & cl.Value
        Next

    sCC = Mid(sCC, 2)
    Set OApp = CreateObject("Outlook.Application")
    Set OMail = OApp.CreateItem(0)
    With OutApp
    .To = sTo
    .CC = sCC
    .Subject = "Location " & rng1
    .BodyFormat = olFormatHTML
   .HTMLBody = "<p> Hello, </p><p>Your delivery information is below: </p><p> 
    Deliver Number: " & sDelivery & "<p/> <p> Trailer Number: " & sTrailer & " 
    <p/><p>Shipper ID: " & sShipper & "<p/><p>Best Regards </p>"
        .display
    End With

        Set OMail = Nothing
        Set OApp = Nothing
        Set eRng1 = Nothing
        Set eRng2 = Nothing
        sTo = ""
        sCC = ""
    Next i

    End Sub

1 Ответ

0 голосов
/ 23 февраля 2019

Я вижу, что вы пытаетесь сделать сейчас.Вы должны сместить цикл с каждого столбца на ряд.Что-то вроде ... , если в строке нет члена выше, соберите все соответствующие элементы в столбце строки, затем выполните цикл по оставшимся строкам, проверяя, совпадают ли они, и затем добавляя их в электронное письмо .

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

Sub SendIntransitEmail()

    Dim Mail_Object, OutApp As Variant
    Dim eRng1, eRng2, eRng3, rng1, rng2, rng3, rng4, cl As Range
    Dim sTo, sCC, sLoc, sFile1, sFile2, sHeader, sBody As String

    Set rng4 = ThisWorkbook.Worksheets("sheet1").Range("B4")

    Dim intNum As Integer
        intNum = ThisWorkbook.Worksheets("sheet1").Range("B1")

    Set Mail_Object = CreateObject("Outlook.Application")


    For i = 5 To intNum
    On Error Resume Next 'I wouldn't use this...

        'test if first instance of plant
        If New_Plant_Test(ThisWorkbook.Worksheets("sheet1").Cells(i, 1)) = True Then
            'run a loop from this row all the way down to populate the respective emails,
            'example:
                For Each rcell In Range(ThisWorkbook.Worksheets("sheet1").Cells(i, 1), ThisWorkbook.Worksheets("sheet1").Cells(intNum, 1)).Cells
                        'apply respective values to variables in that row.
                        'this should probably be a separate private macro.
                Next rcell

            'send email and clear variables and clear variables

        Else
            'skips as plant already existed
        End If

    Next i 'continue loop by each row

    End Sub

Private Function New_Plant_Test(rng As Range) As Boolean

Dim tRow As Long, ws As Worksheet
tRow = rng.Row
Set ws = Sheets(rng.Parent.Name)

On Error GoTo NewMember
    tRow = Application.WorksheetFunction.Match(ws.Cells(tRow, 1), Range(ws.Cells(1, 1), ws.Cells(tRow - 1, 1)), False)
On Error GoTo 0

Exit Function
NewMember:
    New_Plant_Test = True

End Function
...