Office: Email versenden mit variablen Text

Joarks · 9. August 2014

Hallo zusammen,

ich habe eine kleine Herausforderung, die wahrscheinlich schon mal in ähnlicher Weise gelöst wurde. Vielleicht kann mir jmd dabei helfen:

Ich habe eine Excel-Tabelle mit den Namen der Lieferanten, dem Material, Emailadressen und Herkunftsland (siehe Beispieldatei). Beispieldatei.xlsx

Jetzt soll an jeden Lieferanten eine Email geschickt werden, wo ein Standardtext drin steht und die jeweiligen Materialnummern.
Die Schwierigkeit für mich besteht jetzt darin, ein Array zu erstellen, welches diese Aufgabe erfüllt.

Bsp.: Es gibt den Lieferanten "A", der drei verschiedene Materialnummern hat. Jetzt soll an diesen Lieferanten aber nur eine Email mit den drei dazugehörigen Materialnummern geschickt werden.

Wenn jmd da eine Lösung kennt, wäre das echt top.*Smilie

Das Problem, dass abhängig vom Land der Text auf deutsch oder englisch geschickt wird und dass eine PDF-Datei angehängt wird, ist meine Sache und werde mich parallel darum kümmern.

Mfg Alex

:)

Beverly · 11. August 2014

Hi Alex,

hier eine Möglichkeit:

Code:

Sub MailSenden()
Dim objDictionary As Object
Dim varBereich As Variant
Dim lngZeile As Long
Dim arrDaten As Variant
Dim rngZelle As Range
Dim strStart As String
Dim strMaterial As String
Dim lngLetzte As Long
Set objDictionary = CreateObject("Scripting.Dictionary")
' letzte belegte Zeile in Spalte A ermitteln
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
varBereich = Range(Cells(2, 1), Cells(lngLetzte, 1))
' Schleife über alle Werte des Bereichs
For lngZeile = LBound(varBereich) To UBound(varBereich)
objDictionary(varBereich(lngZeile, 1)) = 0 ' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
Next
' Werte in ein Array übergeben
arrDaten = objDictionary.keys
' alle Lieferanten im Array durchlaufen
For lngZeile = 0 To UBound(arrDaten) - 1
Set rngZelle = Columns(1).Find(arrDaten(lngZeile), lookat:=xlWhole)
' Kieferant ist mehrfach vorhanden
If Application.CountIf(Columns(1), arrDaten(lngZeile)) > 1 Then
strStart = rngZelle.Address
Do
strMaterial = strMaterial & ", " & rngZelle.Offset(0, 1)
Set rngZelle = Columns(1).FindNext(rngZelle)
Loop While Not rngZelle Is Nothing And rngZelle.Address strStart
Else
strMaterial = rngZelle.Offset(0, 1)
End If
If Left(strMaterial, 1) = "," Then strMaterial = Mid(strMaterial, 3)

' ab hier dann dein Code für das Erstellen der Mail
' mit rngZelle.Offset(0, 3) hast du die Mailadresse

strMaterial = ""
Next lngZeile
Set objDictionary = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Joarks · 11. August 2014

Vielen Dank für die schnelle und auch gute Antwort. Jetzt kommt allerdings meine Unfähigkeit den Code für den Versand der Email richtig einzubauen. Meiner Meinung nach müsste das doch so gehen? Oder habe ich einen Denkfehler? *confused.gif*

Code:

Sub MailSenden()
Dim objDictionary As Object
Dim varBereich As Variant
Dim lngZeile As Long
Dim arrDaten As Variant
Dim rngZelle As Range
Dim strStart As String
Dim strMaterial As String
Dim lngLetzte As Long
Set objDictionary = CreateObject("Scripting.Dictionary")
' letzte belegte Zeile in Spalte A ermitteln
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
varBereich = Range(Cells(2, 1), Cells(lngLetzte, 1))
' Schleife über alle Werte des Bereichs
For lngZeile = LBound(varBereich) To UBound(varBereich)
objDictionary(varBereich(lngZeile, 1)) = 0 ' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
Next
' Werte in ein Array übergeben
arrDaten = objDictionary.keys
' alle Lieferanten im Array durchlaufen
For lngZeile = 0 To UBound(arrDaten) - 1
Set rngZelle = Columns(1).Find(arrDaten(lngZeile), lookat:=xlWhole)
' Kieferant ist mehrfach vorhanden
If Application.CountIf(Columns(1), arrDaten(lngZeile)) > 1 Then
strStart = rngZelle.Address
Do
strMaterial = strMaterial & ", " & rngZelle.Offset(0, 1)
Set rngZelle = Columns(1).FindNext(rngZelle)
Loop While Not rngZelle Is Nothing And rngZelle.Address strStart
Else
strMaterial = rngZelle.Offset(0, 1)
End If
If Left(strMaterial, 1) = "," Then strMaterial = Mid(strMaterial, 3)

'----------------------
'Hier fängt die Email an

Dim OutApp As Object
Dim objOLMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set objOLMail = OutApp.CreateItem(0)

With objOLMail

.To = rngZelle.Offset(0, 3)

If rngZelle(0, 5) = "DE" Then
.Subject = "Langzeitlieferantenerklärung XXX" '"Betreffzeil"
Else
.Subject = "Long-term agreement XXX"

End If

If rngZelle(0, 5) = "DE" Then
.htmlbody = "Sehr geehrte Damen und Herren," _
& "" _
& "XXX" _
& "" _
& strMaterial _

Else
.htmlbody = "Dear Ladies and Gentlemen," _
& "" _
& "XXX"_
& "" _
& strMaterial _

.Subject = ""
.Body = ""
.Send 'Versand
'.Display

Set objOLMail = Nothing
Set OutApp = Nothing

'--------------------
'Email Ende

' ab hier dann dein Code für das Erstellen der Mail
' mit rngZelle.Offset(0, 3) hast du die Mailadresse

strMaterial = ""
Next lngZeile
Set objDictionary = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Beverly · 11. August 2014

Der code für die mail müsste m.E. so aussehen:

Code:

' Beginn E-mail
'----------------------
Dim obNachricht As Object
Dim obMail As Object
Set obMail = CreateObject("Outlook.Application")
Set obNachricht = obMail.CreateItem(0)
With obNachricht
If rngZelle.Offset(0, 3).Hyperlinks.Count > 0 Then
.To = rngZelle.Offset(0, 3).Hyperlinks(1).Name
Else
.To = rngZelle.Offset(0, 3)
End If
If rngZelle.Offset(0, 4) = "DE" Then
.Subject = "Langzeitlieferantenerklärung XXX" '"Betreffzeil"
.Body = "Sehr geehrte Damen und Herren," _
& vbLf & vbLf & "XXX" & vbLf & strMaterial
Else
.Subject = "Long-term agreement XXX"
.Body = "Dear Ladies and Gentlemen," _
& vbLf & vbLf & "XXX" & vbLf & strMaterial
End If
.display
' .send
End With
Set obNachricht = Nothing
Set obMail = Nothing
'--------------------
'Email Ende
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Joarks · 11. August 2014

Läuft klasse!!

Vielen vielen Dank!*Smilie *Smilie

Office: Email versenden mit variablen Text

Email versenden mit variablen Text

Email versenden mit variablen Text

Email versenden mit variablen Text

Email versenden mit variablen Text - Similar Threads - Email versenden variablen

Bericht als PDF versenden und dabei umbenennen

Schaltfläche versenden

Email nur versenden wenn Inhalt in Bereich

Schaltfläche Email versenden

Abfrage als Anhang per Email (VBA) versenden

Outlook versende keine emails mehr ??

Problem beim Versenden eines Anhangs via Word->Freigabe->EMail->Outlook