Hallo zusammen,
ich habe einen relativ einfachen Code zusammengeschrieben und -kopiert, um eine einfache Excel-Tabelle bestehend aus 4 Spalten und mehreren Zeilen zu durchlaufen und einzelne Mails per Outlook zu generieren. In den Spalten stehen die Namen von Projektmanagern (A), deren Emailadresse (B), ein zugehöriger Projektcode (C) und ein Marker (D), der "ja" oder "nein" sein kann, je nachdem ob eine Mail verschickt werden soll oder nicht. Das Makro durchläuft diese Liste und generiert eine Mail inkl. Anhang des jeweilig richtigen Projektberichts (Excelfile).
Nun ist es so, dass in der Liste teilweise Namen mehrfach vorkommen können mit verschiedenen Projekten. Mein Ziel wäre, dass aber pro Name nur eine Mail generiert wird und alle zugehörigen Anhänge in dieser einen Mail beigefügt werden.
Ich habe den Ansatz über einen Autofilter, der die jeweiligen Namen filtert und dann würde ich den gefilterten Bereich mit einer weiteren Schleife durchlaufen und die Anhänge entsprechend beifügen. Leider funktioniert diese zweite Schleife nicht richtig, d.h. es werden nicht mehrere Excelfiles beigefügt, sondern immer nur das erste aus der gefilterten Liste.
Hat jemand von euch vielleicht eine Idee, was falsch sein könnte oder wie es besser funktioniert?
Sub Test()
Dim wb As Workbook
Dim a As Range
Dim b As Range
Dim RangeArr As Range
Dim lastRow As Long
Dim iRows As Long
Dim objOutlook As Object
Dim objEmail As Object
Dim Ablage As DataObject
Dim AtchFile1 As String
Dim strOrdner As String
Set wb = ThisWorkbook
' With Application.FileDialog(msoFileDialogFolderPicker)
' .InitialFileName = Environ("UserProfile") & "\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 ("No Folder selected!")
' Exit Sub
' End If
strOrdner = "C:\Beispielpfad\"
With wb.Worksheets("Tabelle1").Range("C2").CurrentRegion
For Each a In .Columns(1).Offset(1).Cells
If a > "" Then
For Each b In Range(.Columns(1).Cells(1), a.Offset(-1))
If b = a Then Exit For
Next b
If b Is Nothing Then
.AutoFilter Field:=1, Criteria1:=a
Set RangeArr = wb.Worksheets("Tabelle1").Range("A2:D65454").SpecialCells(xlCellTypeVisible)
If RangeArr.Cells(1, 4).Value = LCase("yes") Then
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(olMailItem)
Set Ablage = New DataObject
wb.Worksheets("Tabelle2").Range("B3:B8").Copy
With objEmail
.To = RangeArr.Cells(1, 2)
'.Subject = ws.Range("B1").Value & " | " & arrRange.Cells(intRow, 3).Value
.Subject = "test"
Ablage.GetFromClipboard
.Body = Ablage.GetText(1)
.Display
For iRows = 2 To RangeArr.Rows.Count
AtchFile1 = RangeArr.Cells(iRows, 3)
.Attachments.Add strOrdner & Dir(strOrdner & "*" & AtchFile1 & "*xls*")
Next iRows
End With
Else
End If
Set objEmail = Nothing
Set objOutlook = Nothing
End If
End If
Next a
.AutoFilter Field:=1
End With
End Sub
Vielen Dank!!