Hallo zusammen,
ich möchte mehrere Tabellenblätter an unterschiedliche Mail-Adressen versenden. Ich bin absoluter VBA-Neuling, habe auf einer Website einen entsprechenden Code gefunden, komme damit aber nicht weiter. Auf der Website ist vermerkt, dass man lediglich das Makro "lop" (bei mir heißt es "neu") starten soll, dann würde alles funktionieren. Bei mir kommt allerdings der Laufzeitfehler 1004.
Ist es zudem möglich, noch einen E-Mail-Text vorzugeben, der durch die Standard-Signatur in Outlook ergänzt wird?
Könnt ihr mir bitte helfen? Vielen Dank vorab!
Sub Blattversand()
' Fehlermeldungen werden ausgeschaltet. Dateien werden gespeichert, auch wenn schon eine mit
' diesem Namen existiert. Vorherige Datei wird überschrieben.
Application.DisplayAlerts = False
Application.Volatile
' Blattname wird ausgelesen
Blattname = ActiveSheet.Name
BlattName2 = Blattname & ".xlsx"
' Pfadname zum Zwischenspeichern wird vorgegeben
pfadname = "C:\Users\gccai\EIGENE DATEIEN\GCCAI\Arzt Apothekenabverkaufsdaten Temp\" & Blattname & ".xlsx"
' neue Arbeitsmappe anlegen mit dem Blattnamen zwischenspeichern
Set neuemappe = Workbooks.Add
With neuemappe
.SaveAs Filename:=pfadname
End With
' zur =Originalmappe wechseln und die Meldung in die neu erzeugte Mappe kopieren, vor Tabelle 1
ThisWorkbook.Activate
Sheets(Blattname).Copy Before:=Workbooks(BlattName2).Sheets(1)
' Leertabellen löschen
tabzahl = Sheets.Count
stammwert = 1
For tz = stammwert To tabzahl
If tabzahl = stammwert Then Exit For
If tz = tabzahl Then Exit For
tabname = "Tabelle" & tz
Sheets(Array(tabname)).Select
ActiveWindow.SelectedSheets.Delete
Next
' Datei mailen
mailadresse = Range("F1")
ActiveWorkbook.SendMail Recipients:=mailadresse, Subject:=Blattname
' es wäre schön, wenn in einer Zelle jedes Blattes die Mailadresse stehen könnte (z.B. F1)
' Die erzeugte Arbeitsmappe nach dem Versand per Mail schliessen und anschließend aus dem Verzeichnis löschen
ActiveWindow.Close
On Error Resume Next
Kill (pfadname)
End Sub
Sub Neu()
' loopFunktion wählt nacheinander jedes Blatt in der Datei aus und startet dann
' obriges Makro zum Mailen
Dim Sh As Worksheet
For Each Sh In Worksheets
Sh.Activate
Call Blattversand
Next Sh
End Sub
Beste Grüße
Carsten
|