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:
Projektnummer |
Name Empfänger 1 |
Email 1 |
Name Empfänger 2 |
Email 2 |
Dateianhang |
abcdef |
Max Mustermann |
max.mustermann@idk.de |
Hans Müller |
hans.müller@idk.de |
abcdef.xlsm |
... |
... |
... |
... |
... |
... |
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
|