E-Mail Empfänger aus Zelle/Blatt auswählen
13.11.2019 11:27:02
Niko
brauche wieder einmal eure Hilfe.
Habe Ein Arbeitsplan erstellt und möchte diesen an verschieden Kollegen senden. Da aber die Kollegen je nach Bauprojekt Variieren, kann ich keine feste Adressen zuweisen. Je nach Bauprojekt Variieren die Kollegen und deshalb möchte ich das das Makro die E-Mails der Kollegen vom Blatt, Bereich E-Mail Empfänger E47:E57 entnimmt. So brauche ich ( und die anderen Benutzer) nicht dauernd das Makro zu ändern wenn ein andere Kollege hinzukommt oder das Projekt wechselt.
Bis jetzt habe ich es mit verschiedenen copy-Paste Annährungen und Hilfe aus dem net, es Geschafft das es an bestimmte Adressen senden tut (mit vorgegebenen Bereich), die aber im Makro enthalten ist.
Wer kann mir helfen, die Adressen aus dem Bereich E47:E57 automatisch im Makro übernommen werden? ...ohne etwas anderes zu ändern.
Danke im Voraus,
Niko
Anbei die Datei mit dem Makro sowie das Makro selbst.
https://www.herber.de/bbs/user/133171.xlsm
Sub Excel_Sheet_via_Outlook_JanEZL()
'ActiveWorkbook.ActiveSheet.Unprotect ("1234")
Dim GruppenName, KasseMonat As String
GruppenName = ThisWorkbook.Sheets("DPV1").Range("A3")
KasseMonat = Month(CDate(ThisWorkbook.Sheets("DPV1").Range("E4"))) & "/" & Year(CDate( _
ThisWorkbook.Sheets("DPV1").Range("E4")))
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String
SavePath = Environ("TEMP")
Worksheets("DPV1").Copy
With ActiveSheet
With .UsedRange
.Copy
.PasteSpecial xlPasteValues
End With
Union(.Range("CD:CR"), .Range("CS:DG"), .Range("DH:XFD")).Delete
.Range("61:1048576").Delete
End With
ActiveSheet.UsedRange.Copy
ActiveSheet.Cells().PasteSpecial xlPasteValues
Application.Workbooks(Application.Workbooks.Count).SaveAs ThisWorkbook.Path & "\" & " _
Dienstplangestaltung" & "_" & GruppenName & "_" & Format(Now, "ddmmyyyy__hhmm") & ".xlsx"
With Application.Workbooks(Workbooks.Count)
AWS = .FullName
.Close
End With
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.to = "Kol.1@test.de"
.Subject = "Dienstplangestaltung - Gruppe: " & GruppenName & " - Monat: " & KasseMonat & _
" - " & Date & "-" & Time
.Attachments.Add AWS
.Body = "Hallo Kollege," & vbCrLf & vbCrLf & "Im Anhang dieser E-Mail befindet sich die _
Dienstplanung unserer Baugruppe in Form einer Excel Datei." & vbCrLf & "Die Datei wird automatisch generiert, bitte beim Aufmachen der Datei alle Vormeldungen zu akzeptieren/aktivieren oder/und auf Weiter zu Drücken." & vbCrLf & vbCrLf & "Zu öffnen mit dem MS Excel Programm oder einem Excel kompatiblen Programm." & vbCrLf & vbCrLf & vbCrLf & "Vielen Dank," & vbCrLf & GruppenName & ""
.GetInspector
.Display
'.Send
Kill AWS
End With
'MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
'ActiveWorkbook.ActiveSheet.Protect ("1234")
End Sub