Hallo liebes Forum, 

ich habe untenstehenden Code geschrieben (und zusammenkopiert), um mittels VBA eine standardisierte Email per Outlook an eine Reihe von Empfängern zu versenden.

Die entsprechenden Empfänger sind im Sheet "Contacts" in einer Namerange hinterlegt, welche folgenden Aufbau hat:

Der Code funktioniert soweit auch (ein paar Schönheitskorrekturen kommen noch), aber ein Feature würde ich gern einbauen, für das mir das KnowHow fehlt.

Es kann vorkommen, dass die gleichen Empfänger (1 & 2) verschiedene Projekte betreuuen. Im besten Fall sollten sie dann jedoch nur eine Email erhalten, wo alle "ihrer" Projektberichte im Anhang sind. Meine (Traum-)Vorstellung wäre, dass, NUR wenn empfänger 1 & 2 gleich sind, eine einzelne Email generiert wird, die alle Projektberichte im Anhang beinhaltet sowie alle entsprechenden Projektnummern in der Betreffzeile. Falls sie abweichen, sollen wieder eigenständige Emails generiert werden für jedes Projekt.

Ist dies über eine Schleife, Array oder ähnliches machbar?

Ich wäre über jede Hilfe dankbar!

Viele Grüße und schonmal vielen Dank für eure Unterstützung

LayzR

Private Sub CommandButton1_Click()

On Error GoTo ErrHandler

Dim wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Object
Dim objEmail As Object
Dim arrRange As Range
Dim intRow As Integer
Dim iRows As Integer
Dim path As String
Dim strOrdner As String
Dim strBody As String
Dim i As Integer


Set wb = ThisWorkbook
Set ws = ThisWorkbook.Worksheets("Contacts")

Set arrRange = ThisWorkbook.Names("ContactsRange").RefersToRange

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "C:\Users\abcdef\Desktop"
    .Title = "Ordnerauswahl"
    .ButtonName = "Auswahl"
    .InitialView = msoFileDialogViewList
    
    If .Show = -1 Then
        strOrdner = .SelectedItems(1)
        If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
    Else
        strOrdner = ""
    End If
End With
    If strOrdner = "" Then
        MsgBox ("Kein Ordner gew‰hlt")
        Exit Sub
    End If
    

For intRow = 1 To arrRange.Rows.Count

If Not IsEmpty(arrRange.Cells(intRow, 1)) = True Then

Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(olMailItem)

strBody = "Dear " & arrRange.Cells(intRow, 2) & "," & "<br><br>"
    With wb.Worksheets("Options")
        For i = 6 To 9
            strBody = strBody & .Cells(i, "C").Value & "<br>"
        Next i
    End With
    
    

With objEmail
    .GetInspector.Display
    .To = arrRange.Cells(intRow, 3)
    .Subject = wb.Worksheets("Options").Range("C3").Value & " " & arrRange.Cells(intRow, 1)
    '.CC
    
    .Display
    .htmlBody = strBody
    '.Send
    .Attachments.Add strOrdner & arrRange.Cells(intRow, 4) & ".xlsm"
End With

Set objEmail = Nothing
Set objOutlook = Nothing


End If

Next intRow

ErrHandler: Exit Sub
    
    
End Sub