Option Explicit
Dim ExcelObjekt, Zaehler, n
Dim strID, strFirstName, strLastname, strAP
Dim Anzahl, Liste, Message
Dim ol, Mail
Set ExcelObjekt = CreateObject("Excel.Application")
ExcelObjekt.Visible = False
ExcelObjekt.Workbooks.Open "C:\Temp\AP Liste.xls"
Anzahl = ExcelObjekt.Worksheets(1).Cells(1,1).End(4)
Anzahl = Anzahl + 1
Dim Speicher(32000)
For n = 2 To Anzahl
Speicher(n) = True
Next
For Zaehler = 2 To Anzahl
With ExcelObjekt
If Speicher(Zaehler) Then
Liste = ""
strID = .Cells(Zaehler,1).Value
strFirstName = .Cells(Zaehler,2).Value
strLastName = .Cells(Zaehler,3).Value
strAP = .Cells(Zaehler,4).Value
Message = vbCrLf & _
"Sehr geehrte(r) " & strAP & "," & vbCrLf & _
vbCrLf & _
"Sie betreuen folgende Personen: " & vbCrLf & _
vbCrLf
For n = 2 To Anzahl
If Speicher(n) Then
If strID <> .Cells(n,1).Value Then
If strAP = .Cells(n,4).Value Then
Liste = Liste & .Cells(n,1).Value & " : " & .Cells(n,2).Value & " " & .Cells(n,3).Value & vbCrLf
Speicher(n) = False
End If
Else
Liste = Liste & strID & " : " & strFirstName & " " & strLastName & vbCrLf
Speicher(n) = False
End If
End If
Next
Message = Message & Liste & vbCrlF & _
vbCrLf & _
"Mit freundlichen Grüßen" & vbCrLf & _
vbCrLf & _
"Alexandra 2011"
Set ol = CreateObject("Outlook.Application")
Set Mail = ol.CreateItem(0)
Mail.Subject = "Liste der Betreuenden vom: " & Date
Mail.To = "ansprechparter@Mustermann.domain"
Mail.cc = ""
Mail.bcc = ""
Mail.body = Message
Mail.Display
End If
End With
Next
ExcelObjekt.Quit