Tabellenblatt aufteilen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
mal ein Beispiel.
Der Code gehört in ein Modul deiner Arbeitsmappe
In deiner Mappe "Alt"+"F11" drücken
Unter "VBA Projekt "DeineMappe.xls". Rechte Maustaste - Einfügen Modul.
Den Code hier kopieren, dort dann einfügen.
Deine Ausgangstabelle sieht im Beispiel mal so aus:

	A	B	C
1	Name	Mailadresse
2	Rainer	ramses@gmxpro.netz
3	Ramses'	ramses@gmxpro.nez
4	Ramses
5	Max Mustermann, der einhunderdste Mailempfänger	max.mustermann@irgendwo.netz
6

Dann lass diesen Code laufen
Option Explicit

Sub Excel_Serienmail_via_Outlook_mit_Anhang_Senden()
'(C) Ramses
Dim tWks As Worksheet, qWks As Worksheet, qWB As Workbook
Dim tmpWB As String, tmpFolder As String
Dim wksFound As Boolean, notSend As Boolean
Dim NotSendSheet As Worksheet
Dim NotSendRow As Integer
Dim MyOutApp As Object
Dim MyMessage As Object
Dim mySender As String, MyDefPath As String, tmpName As String
Dim i As Integer, n As Integer, NameCol As Integer, MailCol As Integer
'Fehlerbehandlung einschalten
On Error GoTo MyErrorHandler
'Überschrift steht in Zeile 1
'Namen stehen in Spalte NameCol
'E-Mail Addressen in Spalte MailCol
'Sonderzeichen in den Namen werden NICHT berücksichtigt
'Fehlerprotokoll wird erstellt
'--------------------------
'Tabelle wo die Namen und Adressen stehen
Set qWks = ThisWorkbook.Worksheets("Tabelle1")
'Spalte wo die Namen stehen
'1 = Spalte A
NameCol = 1
'Spalte wo die E-Mailadressen stehen
'2 = Spalte B
MailCol = 2
'Temporäres DokuSheet anlegen wenn Dateien nicht erstellt werden können
Set NotSendSheet = Worksheets.Add
NotSendSheet.Name = Date & " " & Format(Time, "hh_mm_ss")
'Temporäres Verzeichnis anlegen für die Zwischenspeicherung der Daten
tmpFolder = "C:\" & Date & "_" & Format(Time, "hh_mm_ss")
MkDir tmpFolder
NotSendRow = 1
notSend = False
'Absender
mySender = "Herzliche Grüsse" & vbCrLf & "Ramses"
'Default Speicherpfad
MyDefPath = Application.DefaultFilePath
'Outlook Object erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Start der Sendeschleife
With qWks
    For i = 2 To .Cells(Rows.Count, NameCol).End(xlUp).row
        'Controlflag für zu sendendes Object erstellen
        wksFound = False
        'Sendeschleife starten
        NewStart:
        For n = 1 To Worksheets.Count
            If Worksheets(i).Name = .Cells(i, NameCol) Then
                wksFound = True
                Exit For
            End If
        Next n
        If IsEmpty(.Cells(i, MailCol)) Then
            notSend = True
            EnterErrorMessage NotSendSheet.Name, NotSendRow, i, qWks.Cells(i, NameCol).Text, "Keine Mailadresse"
            NotSendRow = NotSendRow + 1
            GoTo SendNextMessage
        End If
        If wksFound = False Then
            'Outlook Mail erstellen
            Set MyMessage = MyOutApp.CreateItem(0)
            Set tWks = Worksheets.Add
            tWks.Name = .Cells(i, NameCol)
            tWks.Copy
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs tmpFolder & "\" & .Cells(i, NameCol).Text & ".xls"
            Application.DisplayAlerts = True
            Set qWB = Workbooks(ActiveWorkbook.Name)
            With MyMessage
                .To = qWks.Cells(i, MailCol).Text '"irgendwer@irgendein-provider.de"
                .Subject = "Ihre Datei" 'oder z.B. qwks.Cells(i, 4) 'Betreff in Spalte D
                .Body = "Zu Ihrer Info" & vbCrLf & mySender 'oder z.B. qwksCells(i, 5) 'Infotext in Spalte E
                .Attachments.Add qWB.FullName
                'Hier wird die Mail zuerst angezeigt
                '.Display
                'Hier wird die Mail gleich in den Postausgang gelegt
                .Send
            End With
            'Name temporär speichern
            tmpName = qWB.FullName
            'Erstelltes Workbook schliessen
            qWB.Close
            'Löschen des erstellten temporären Workbooks
            Kill tmpName
            'Variablen zurücksetzen
            Set MyMessage = Nothing
            'Application.Wait (Now + TimeValue("0:00:02"))
        End If
        Set qWB = Nothing
        Set tWks = Nothing
        SendNextMessage:
    Next i
End With

MyErrorExit:
Application.ScreenUpdating = True
Set MyOutApp = Nothing
On Error GoTo 0
'Löschen des temporären Folders
RmDir tmpFolder
If notSend = False Then
    'Wenn keine Sendefehler auftraten
    'Kann das Protokollsheet gelöscht werden
    Application.DisplayAlerts = False
    NotSendSheet.Delete
    Application.DisplayAlerts = True
Else
    'Anzeigen der Fehlerdatei in der aktiven Mappe
    NotSendSheet.Select
    MsgBox "Es konnten diverse Namen nicht gesendet werden"
End If
Exit Sub

MyErrorHandler:
Select Case Err
    Case 1004
        notSend = True
        'Löschen einer temporär erstellten Datei in der aktiven Mappe
        Application.DisplayAlerts = False
        tWks.Delete
        Application.DisplayAlerts = True
        If Len(qWks.Cells(i, NameCol)) > 31 Then
            EnterErrorMessage NotSendSheet.Name, NotSendRow, i, qWks.Cells(i, NameCol).Text, "Name zu lang"
        Else
            EnterErrorMessage NotSendSheet.Name, NotSendRow, i, qWks.Cells(i, NameCol).Text, "Unerlaubte Zeichen"
        End If
        NotSendRow = NotSendRow + 1
        Resume SendNextMessage
    Case Else
        MsgBox "Unerwarteter Fehler" & vbCrLf & vbCrLf & Err.Number & ", " & Err.Description, vbCritical, "Sende Makro wird abgebrochen"
        Resume MyErrorExit
End Select
End Sub

Function EnterErrorMessage(shToWrite As String, shRow As Integer, shNotSendRow, SendName As String, Reason As String)
Worksheets(shToWrite).Cells(shRow, 1) = "Zeile " & shNotSendRow
Worksheets(shToWrite).Cells(shRow, 2) = SendName
Worksheets(shToWrite).Cells(shRow, 3) = Reason
End Function

Danach sollte die Protokolldatei in etwa so aussehen

	A	B	C	D
1	Zeile 3	Ramses'	Unerlaubte Zeichen
2	Zeile 4	Ramses	Keine Mailadresse
3	Zeile 5	Max Mustermann, der einhunderdste Mailempfänger	Name zu lang
4

Viel Spass
Gruss Rainer
@Nepumuk: Das war ein Notfall :-))

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread