Hallo Michael. Ich habe das ganze einmal in ein Makro gesetzt.
Wichtig: in dem Ordner in dem du die Sheetstabelle hast musst du einen Ordner Temp erstellen oder den Pfad ändern.
Versuche einfach einmal damit durchzukommen, ansonsten schreib mir.
Gruß Bernd
Ab hier:
Option Explicit
Sub Mail_senden()
'Starten aus der Persnal.xlsb. Gestartet wird mit offener und aktivierter Quelldatdei (die mit den Sheets)
' In dieser Version ist die Datei mit den Mailadressen fest vergeben.
Dim ws As Worksheet
Dim i As Integer
Dim MsgTxt As String
Dim QName As String
Dim QSheet As String
Dim QPath As String
Dim ZPath As String
Dim ZName As String
Dim ZSheet As String
Dim strBlatt As String
Dim strDatei As String
Dim strPfad As String
Dim outObj As Object
Dim Mail As Object
Dim strBodyText As String
Dim rngDatenQuelleNr As Excel.Range
Dim rngDatenZielNr As Excel.Range
Dim Suchwert As String
Dim Gefunden As Variant
Dim MailSpalte As String
Dim Mailadresse As String
Dim rngDatenZiel As Excel.Range 'Zielrange Wo stehen die Werte die durchsucht werden
Dim ZZeile As Long
ZName = ActiveWorkbook.Name 'Erstellt sich aus aktiver Quelldatei (Datei mit den Sheets zum Versand)
ZSheet = ActiveSheet.Name 'Erstellt sich aus aktiven Quellsheet
ZPath = ActiveWorkbook.Path 'Erstellt sich aus aktiven Quellpfad
strPfad = ZPath '"C:\Temp" 'entsprechend anpassen. Pfad für temporäre Zwischenspeicherung angeben. Ich nutze hierfür einfach den Pfad wo die Sheetstabelle liegt.
QPath = "C:\Test\" 'Pfad zur Datei mit den Mailsheets
QName = "Mailadresssen.xlsx" 'Name der Datei mit den Mailadressen.xls(m)
QSheet = "Adressen" 'Sheet in der die Mailadressen stehen
MailSpalte = "B" ' in dieser Spalte steht die Mailadresse
'Abfrage unbedingt aktivieren, sonst kommst du bei einer Falseingabe nicht mehr heraus und versendest weiß sonst was.
MsgTxt = "Ist das wirklich die Datei deren Sheets du versenden möchtest?" & vbCr & ZName & vbCr & "und das die Tabelle aus der du die Mailadressen bekommst?" & vbCr & QName
If MsgBox(MsgTxt, vbYesNo Or vbQuestion, "ADAM Export") = vbNo Then
Exit Sub ' 2. weiterbearbeiten =>raus
End If ' 1. Weiter mit Makro
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXStart der SchleifeXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Schleife
i = 1
For Each ws In Worksheets
Sheets(i).Activate
strBlatt = ActiveSheet.Name ' Aktuelles aktives Blatt in neue Arbeitsmappe kopieren
Sheets(strBlatt).Copy ' Gewähltes Tabellenblatt kopieren
ActiveWorkbook.SaveAs strPfad & "\Temp\" & ActiveSheet.Name ' Blatt temporär in vorgegebenes Verzeichnis abspeichern
ZSheet = ActiveSheet.Name 'Erstellt sich aus aktiven Quellsheet
strDatei = ActiveWorkbook.FullName ' Pfad und Dateiname der neuen Datei zwischenspeichern
'Jetzt suchen wir aufgrund des Namens die Mailadresse
Suchwert = ZSheet
'Sheetnamen in der DatenZiel
With Workbooks(QName).Worksheets(QSheet) ' mit der Maildatei
Set rngDatenZiel = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) 'Die Range "A2" bis letzte Zeile in Spalte "A"
End With
Gefunden = Application.Match(Suchwert, rngDatenZiel, 0)
If IsNumeric(Gefunden) Then ' Wenn Suchbegriff in Zielsheet vorhanden, dann...
ZZeile = Gefunden + 1 'Ermitteln der Zielzeile +1 weil Start ab A2
Mailadresse = Workbooks(QName).Worksheets(QSheet).Range(MailSpalte & ZZeile)
End If
' Erstellen der Mail
'** Mail erzeugen
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
With Mail
.To = Mailadresse ' & ";deine.Mail@alsKontrolle.com" 'Dies ist, wenn du noch eine 2. Adresse als permanente zuweisen möchtest (z.B.: als Kontrolle oder deinem Chef oder...).
'.CC = ""
.Subject = Workbooks(QName).Worksheets("Mailtext").Range("A1").Value 'Betreff
.BodyFormat = 2 '2 = HTML, 1 = Text
.Attachments.Add strDatei 'Anhang
.Body = Workbooks(QName).Worksheets("Mailtext").Range("A2").Value 'Bodytext / Signatur
End With
Workbooks(Dir(strDatei)).Close 'Erzeugte Datei schließen
Kill (strDatei) ' Erzeugte Datei wieder löschen
Mail.Display 'Erstellt die Email und öffnet diese. Der Versand erfolgt anschließend manuell vom User!
'.Send 'Sendet die Email automatisch
i = i + 1
Next
Ende:
MsgBox "Makro beendet"
End Sub
|