Option Explicit
Dim ExcelObjekt, Zaehler, n
Dim strID, strFirstName, strLastname, strAP, strEMail
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).UsedRange.Rows.Count
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
Dim Dbs, db, rs
Dim strSQL
Set Dbs = CreateObject("DAO.DBEngine.36")
Set db = Dbs.OpenDatabase("C:\temp\Ansprechpartner.mdb")
strSQL = "SELECT * FROM Ansprechpartner WHERE Name LIKE '"& strAP &"'"
Set rs = db.OpenRecordset(strSQL)
If rs.RecordCount > 0 Then
strEMail = rs.fields(2)
Else
strEMail = ""
End If
rs.Close
Set rs = Nothing
Set db = Nothing
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 = strEMail
Mail.cc = ""
Mail.bcc = ""
Mail.body = Message
Mail.Display
End If
End With
Next
ExcelObjekt.Quit