Automatisierter Email Versand xls vba

Hallo an alle Experten,
ich habe ein größeres Problem bezüglich des Versands von Woksheets als email Anhang und bräuchte dringend Hilfe.
Die Situation ist folgende:
Ich hab in verschiedenen Verzeichnissen(Ordnern) Excel WB (=Berichte/Reports) erzeugt, die jeweils nur aus einem Sheet bestehen welches den gleichen Namen trägt wie das WB selbst!
Es gibt vier verschieden Ordner in denen die Dateien abgelegt werden.
Also in Y:\Reports\FR Reports liegt z.B. ein MAS_FR.xls, dass ein Sheet namens MAS_FR beinhaltet.
Nun habe ich eine Tabelle in einem neuen Workbook erstellt die regeln soll, welcher Benutzer welche Workbooks - bzw. eigentlich welche Worksheets, als email Anhang empfangen soll.
Die Tabelle besteht aus der Spalte A in der die Namen der Sheets (z.B. MAS_FR) gelistet sind und aus zwei Zeilen.
Zeile 1 beinhaltet den Namen des Empfängers / Zeile 2 die Email Adresse des Empfängers.
Wenn ein Empfänger den Report erhalten soll, steht in der entsprechenden Zelle die aus Spaltenangabe A (für den Bericht) und Zeileangabe 2 (Welche Email) besteht eine 1 - ansonsten bleibt die Zelle leer;
..also wenn Zellwert = 1 dann erhält er den Bericht , Wenn Zellwert = leer dann nicht!
Klasse wäre es jetzt allerdings nicht alle Berichte als einzelne .xls Dateien anhängen zu können - sondern vor dem Versand ein WB zu generieren dass alle Berichte (für den jeweiligen Empfänger) in jeweils ein WB mit seinem Namen (Laut Zeile1) kopiert und danach dieses konsolidierte WB als Anhang an die EmpfängerAdresse sendet....
Das ganze sollte geplanterweise als Schleife ablaufen nach dem Motto, gehe Spalte B durch....(Start Zeile 3 bis 400) - für jede Zelle in B in der eine "1" steht gehe zum Sheet in gleichnamiger Datei (Name steht in Spalte A der gleichen Zeile) und kopiere dieses Sheet in ein neues WB mit dem Namen der in B1 (=Empfängernamen) steht und sende dieses WB per Mail an die Email-Adresse in B2....
Umfang ca. 300 Sheets in Spalte A (entspricht 300 .xls _Dateien und ca. 30 Empfänger....
Weiss es nicht genau - aber am Schlauesten wäre es wahrscheinlich zunächst innerhalb der Schleife ein neues WB generieren zu lassen und dann die nachfolgenden Schritte abzuarbeiten?!!
Das übersteigt leider meine VBA Kenntnisse bei weitem obgleich ich sicher bin, dass es für einen Experten ohne größere Probleme machbar sein solllte?!
Vielen Dank schon mal vorab für alle Tipps und Hilfen?! Ihr würdet mir sehr helfen meine Arbeit zu vereinfachen! Natürlich ist es dringend..;-)
Gruß Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long Public Const wDir = "C:\Dokumente und Einstellungen\FR_Reports\" '\ am Ende nicht vergessen! Public Const Blattname = "Tabelle1" ' Name des Blattes dieser Mappe mit den Daten Public Const eZ = 3 'erste Zeile mit Daten (3: d.h. 2 Zeilen Überschrift) Public Const iName = 1 Public Const iEmail = 2 Sub Start() Dim lZ As Long 'letzte Zeile mit Daten Dim ASp As Integer 'Anzahl der Spalten (2 bis ASp) mit Namen Dim ShData As Worksheet Dim strName As String Dim strEmail As String Dim sp As Integer, ze As Integer, anzB As Integer Dim wb1 As Workbook, wbP As Workbook Dim strTemp As String Dim MailDir As String ' Verzeichnis, in dem die personenbezogenen Mappen gespeichert werden ' (\ am Ende nicht vergessen!) MailDir = ThisWorkbook.Path & "\mails\" ' Verzeichnis bei Bedarf erstellen: MakeSureDirectoryPathExists MailDir Application.ScreenUpdating = False Set ShData = ThisWorkbook.Sheets(Blattname) With ShData 'letzte Zeile ermitteln lZ = .Cells(.Rows.Count, 1).End(xlUp).Row If lZ = 1 Then If .Cells(.Rows.Count, 1) "" Then lZ = .Rows.Count If .Cells(1, 1) = "" Then lZ = 0 End If If lZ "" Then anzB = anzB + 1 Set wb1 = Workbooks.Open(wDir & .Cells(ze, 1) & ".xls") If anzB = 1 Then Set wbP = wb1 Else wb1.Sheets(1).Copy After:=wbP.Sheets(wbP.Sheets.Count) wb1.Close False End If End If Next ze If anzB > 0 Then 'personenbezogene Mappe speichern Application.DisplayAlerts = False wbP.SaveAs Filename:=strTemp Application.DisplayAlerts = True wbP.Close Else 'evtl. alte, vorhandene personenbezogene Mappe löschen, wenn keine 'Blätter zum Versenden angegeben wurden If Dir(strTemp) "" Then Kill strTemp End If sp = sp + 1 If sp > .Columns.Count Then Exit Do Loop End With Application.ScreenUpdating = True Application.StatusBar = False End Sub

Beliebteste Forumthreads (12 Monate)

Automatisierter Email Versand xls vba

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Automatisierter Email Versand xls vba

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread