Hallo liebe Excel-/Outlookspezialisten,
ich muss mich wieder mal mit etwas Schwierigem melden.
Ich möchte aus einer Exceldatei eine Mail mit einem vorgegebenen Text an mehrere Teilnehmer, die ebenfalls in einem weiteren Tabellenblatt (Empfängerliste) der selben Datei stehen senden.
Das Klappt soweit einwandfrei.
Nun möchte ich aber CC noch mehrere variierende Teilnehmer aus einer weiteren ich nenne die Liste „CC“ mit dem gleichen Nachrichtentext erreichen.
Das klappt mit cc … innerhalb des Makros ebenfalls einwandfrei.
Jedoch muss ich jedes mal das Makro verändern was sehr lästig ist.
Darüber hinaus sollen weitere Nutzer der selben Datei die gleiche Möglichkeit haben CC div. andere Empfänger mit der Nachricht zu erreichen.
Kurz um ich bekomme das nicht gebacken das Excel die CC Liste (hier stehen die Empfänger in Spalte D ab Zeile 3) aufrufen kann und die weiteren Empfänger in Outlook bei CC eingetragen werden.
Nachfolgend mal das bestehende Makro ich habe einige Zeilen mit Formatierungen etc. am Anfang weggelassen und beginne beim Offnen von Outlook:
Sub Schalter_A1()
’ Makro am 21.04.2016 von Lerfix aufgezeichnet
Application.ScreenUpdating = False
…
Sheets(„Text“).Select
'Hier wird der zusendende Text in die Zwischenablage kopiert
Range(„C5:C7“).Select
Selection.Copy
’ Eintragungen in Outlook
Dim myOutApp As Object, myMessage As Object
'Verweis auf „Microsoft Forms 2.0 Object Library“ (…system32FM20.DLL) aktivieren !!
'sonst geht es nicht
'Dataobject wird gebraucht wegen der Zwischenablage
Dim myClpObj As DataObject
Set myClpObj = New DataObject
Set myOutApp = CreateObject("Outlook.Application")
Set myMessage = myOutApp.CreateItem(0)
'Hier darf nichts verändert werden. Die Bezugstabelle darf ebenfalls nicht verändert werden.
'Es dürfen aber nach Zeile 2 weitere Zeilen hinzugefügt oder auch gelöscht werden.
Dim i As Long
Dim sAbteilung As String
Dim sTemp As String
sAbteilung = Sheets("Empfänger").Cells(1, 2).Value
sTemp = ""
With Sheets("Empfänger ")
For i = 3 To .UsedRange.Rows.Count + .UsedRange.Row - 1
If .Cells(i, 1).Value = sAbteilung Then
sTemp = sTemp & .Cells(i, 4).Value & ";"
End If
Next i
'Das letzte Semikolon entfernen
If Trim(sTemp) <> "" Then
sTemp = Left(sTemp, Len(sTemp) - 1)
End If
End With
'Wenn mindestens eine E-Mail Adresse gefunden wurde wird eine E-Mail vorbereitet:
If Trim(sTemp) <> „“ Then
Set oAppOutlook = CreateObject(„Outlook.Application“)
With oAppOutlook.CreateItem(0)
.To = sTemp 'E-Mail Empfänger String aus sTemp, Exceltabelle („Empfänger“)
.Subject = „xxx“ 'E-Mail Betreffzeile
'.CC = "xxx " 'Zur Zeit deaktiviert
'Zwischenablage wird eingefügt
myClpObj.GetFromClipboard
.Body = myClpObj.GetText(1)
.Display
.send
End With
End If
Set myOutApp = Nothing
Set myMessage = Nothing
'Zur Zeit deaktiviert
'ActiveWorkbook.Save
'ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub
Wie gesagt Das Makro funktioniert. Nur nicht CC aus der Liste.
Wie muss der Befehl lauten und an welcher Stelle muss er eingesetzt werden damit CC die weiteren Empfänger (ca. 1 bis etwa 5 weitere Empfänger) aus der CC Liste in CC Outlook übernommen werden.
Ich muss die wechselnden weiteren „CC Empfänger“ in eine separate Liste aufnehmen, weil jeder Nutzer der Familie eine eigene Variante dieser Datei benutzt.
Ich möchte hiermit verhindern, dass die weiteren Nutzer nichts am Makro versehentlich verändern und ich wieder alles reparieren muss.
Ich habe mir schon die Finger wund gesucht, aber nichts passendes im Netz gefunden. Kann mir jemand helfen?
Bin langsam am verzweifeln?
Ich danke schon mal allen vorab, die sich meines Problems annehmen wollen.
Viele Grüße und eine schönes Wochenende
Lernfix