Liste per Makro versenden

Hallo zusammen,
ich bin neu hier und hoffe ihr könnt mir etwas helfen, da ich einfach nicht weiterkomme...
Es geht darum, dass ich eine Liste mit allen Kunden an den jeweiligen Berater senden möchte. Konto inkl. Name.
Bsp.:
Konto (Spalte A) KdName (Spalte B) Emai (Spalte l)
0000 000000001 Kunde A Berater1@abc.de
0000 000000003 Kunde B Berater2@abc.de
0000 000000004 Kunde C Berater2@abc.de
0000 000000005 Kunde D Berater3@abc.de
Email 1:
An Berater1@abc.de
Text:
0000 000000001 Kunde A
Email2:
An: Berater2@abc.de
Text:
0000 000000003 Kunde B
0000 000000004 Kunde C
Email3:
An: Berater3@abc.de
Text:
0000 000000005 Kunde D
Aktuell werden 4 Emails versendet mit dem folgenden Code:


Sub Email_Versenden()
Dim Konto, Kunde, Betreuer, Empfänger, Empfänger1 As String
i = 2
Do Until ThisWorkbook.Sheets(1).Cells(i, 9) = ""
'------------------------------------------------------------------------------------------- _
_
_
'------------------------------------------------------------------------------------------- _
_
_
Set otlApp = CreateObject("Outlook.Application")
Set OtlNewMail = otlApp.CreateItem(olMailItem)
'------------------------------------------------------------------------------------------- _
_
_
'------------------------------------------------------------------------------------------- _
_
_
'VARIABLEN
'------------------------------------------------------------------------------------------- _
_
_
Konto = ThisWorkbook.Sheets(1).Cells(i, 1)
Kunde = ThisWorkbook.Sheets(1).Cells(i, 2)
Betreuer = ThisWorkbook.Sheets(1).Cells(i, 7)
Empfänger = ThisWorkbook.Sheets(1).Cells(i, 9)
jahr = Right(Date, 4)   'JJJJ
'------------------------------------------------------------------------------------------- _
_
_
'EMAIL-ADRESSE HOLEN
'------------------------------------------------------------------------------------------- _
_
_
j = 2
Email = ""
Do Until ThisWorkbook.Sheets(1).Cells(j, 1) = ""
Empfänger1 = ThisWorkbook.Sheets(1).Cells(j, 9)
If Empfänger = Empfänger1 Then Email = ThisWorkbook.Sheets(1).Cells(j, 9)
j = j + 1
Loop
'------------------------------------------------------------------------------------------- _
_
_
'TEXT
'------------------------------------------------------------------------------------------- _
_
_
Text = "" & Konto & VBA.Constants.vbTab & Kunde & VBA.Constants.vbTab & vbCrLf & vbCrLf
'------------------------------------------------------------------------------------------- _
_
_
'EMAIL VERSENDEN
'------------------------------------------------------------------------------------------- _
_
_
With OtlNewMail
.To = Empfänger
.Subject = "Jahresreport " & jahr
.Body = "Guten Morgen," & vbCrLf & vbCrLf & _
"anbei die Kundenliste:" & vbCrLf & vbCrLf _
& Text _
& "Viele Grüße," & vbCrLf & vbCrLf _
& vbCrLf & vbCrLf
.display
End With
'End If
'------------------------------------------------------------------------------------------- _
_
_
'------------------------------------------------------------------------------------------- _
_
_
i = i + 1
Loop
End Sub

Vielen Dank im Voraus.
Gruß,
Ty

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
teste mal:

Option Explicit

Private Type ACCOUNT
    Empfaenger As String
    Konto() As String
    Kunde() As String
End Type

Public Sub Email_Versenden()

    Dim audtAccount() As ACCOUNT
    Dim lngRow As Long, ialngIndex As Long, ialngTemp As Long
    Dim strEmpfaenger As String, strText As String, strYear As String
    Dim objDictionary As Object
    Dim objOutlook As Object, objMail As Object

    strYear = CStr(Year(Date))

    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")

    With ThisWorkbook.Worksheets(1)

        For lngRow = 2 To .Cells(.Rows.Count, 9).End(xlUp).Row

            If Not objDictionary.Exists(Key:=.Cells(lngRow, 9).Text) Then

                Call objDictionary.Add(Key:=.Cells(lngRow, 9).Text, Item:=ialngIndex)
                Redim Preserve audtAccount(ialngIndex)
                audtAccount(ialngIndex).Empfaenger = .Cells(lngRow, 9).Text
                Redim audtAccount(ialngIndex).Konto(0)
                audtAccount(ialngIndex).Konto(0) = .Cells(lngRow, 1).Text
                Redim audtAccount(ialngIndex).Kunde(0)
                audtAccount(ialngIndex).Kunde(0) = .Cells(lngRow, 2).Text
                ialngIndex = ialngIndex + 1

            Else

                ialngTemp = objDictionary.Item(Key:=.Cells(lngRow, 9).Text)
                Redim Preserve audtAccount(ialngTemp).Konto(UBound(audtAccount(ialngTemp).Konto) + 1)
                audtAccount(ialngTemp).Konto(UBound(audtAccount(ialngTemp).Konto)) = .Cells(lngRow, 1).Text
                Redim Preserve audtAccount(ialngTemp).Kunde(UBound(audtAccount(ialngTemp).Kunde) + 1)
                audtAccount(ialngTemp).Kunde(UBound(audtAccount(ialngTemp).Kunde)) = .Cells(lngRow, 2).Text

            End If
        Next
    End With

    Set objDictionary = Nothing

    Set objOutlook = CreateObject(Class:="Outlook.Application")

    For ialngIndex = LBound(audtAccount) To UBound(audtAccount)

        strEmpfaenger = audtAccount(ialngIndex).Empfaenger

        strText = vbNullString

        For ialngTemp = LBound(audtAccount(ialngIndex).Konto) To UBound(audtAccount(ialngIndex).Konto)

            strText = strText & audtAccount(ialngIndex).Konto(ialngTemp) & vbTab & _
                audtAccount(ialngIndex).Kunde(ialngTemp) & vbTab & vbCrLf & vbCrLf

        Next

        Set objMail = objOutlook.CreateItem(0)

        With objMail

            .To = strEmpfaenger
            .Subject = "Jahresreport " & strYear
            .Body = "Guten Morgen," & vbCrLf & vbCrLf & _
                "anbei die Kundenliste:" & vbCrLf & vbCrLf _
                & strText _
                & "Viele Grüße," & vbCrLf & vbCrLf _
                & vbCrLf & vbCrLf
            .Display

        End With
    Next

    Set objMail = Nothing
    Set objOutlook = Nothing

End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Liste per Makro versenden

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread