Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1664to1668
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
VBA Email versenden
10.01.2019 16:22:51
Alex
Ein freundlichen Hallo an alle,
ich bin neu in der VBA Welt und bräuchte eure Hilfe. Ich weiß nicht mehr, wo ich den u.g. code herhabe. Läuft auch super, nur mein Problem ist, dass mit diesem Code alle Einträge ab Spalte B genommen werden. Ich habe versucht im Code alles um eine Spalte zu verschieben, um Spalte A und D zu benutzen, aber trotzdem nimmt er alles ab Spalte B. Wie kann ich dafür Sorgen, dass er nur die Emails aus B oder C nimmt?
"' EmailInfo starts in column "B" to the last column used.
Set EmailInfo = Intersect(rng, rng.Offset(1, 0))" auch habe ich diese offset rausgelöscht
Meine 2.Frage ist: ich habe eine Checkbox eingebaut um die Möglichkeit zu haben, ob für die Email display oder send ausgeführt werden soll. ich habe versucht vor dem With olApp.CreateItem(0) Befehl die If formel einzusetzen, hat aber nicht funktioniert. Egal was angeklickt war, es war immer true. Was habe ich falsch gemacht?
Vielen Dank für die Hilfe schonmal!
Sub Schritt2_Emails_senden()
Dim Address As Variant
Dim Dict As Object
Dim DstWkb As Workbook
Dim EmailInfo As Variant
Dim Filename As String
Dim i As Long, j As Long
Dim NewWkb As Workbook
Dim olApp As Object
Dim rng As Range
Dim SrcWkb As Workbook
Dim SrcWks As Worksheet
Dim SheetName As String
Dim SheetNames As Variant
Dim SubjectLine As String
Dim MsgBody As String
Dim LastRow As String
Dim MName As String
Dim mySheetName As String
LastRow = Sheets("Contacts").Cells(Rows.Count, 1).End(xlUp).Row
SubjectLine = "Testlauf"
MsgBody = "TEST"
Set rng = Range("A1").CurrentRegion
' EmailInfo starts in column "B" to the last column used.
Set EmailInfo = Intersect(rng, rng.Offset(1, 0))
' Copy the sheet names and email addresses into arrays for faster processing.
SheetNames = EmailInfo.Columns(1).Cells.Value
EmailInfo = Intersect(EmailInfo, EmailInfo.Offset(0, 1)).Value
' Create an associative array to hold the email addresses and the sheet names for  _
each one.
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
' Collect email addresses and sheet names associated with each address.
For i = 1 To UBound(EmailInfo, 1)
For j = 1 To UBound(EmailInfo, 2)
SheetName = SheetNames(i, 1)
Address = EmailInfo(i, j)
If Address  "" Then
If Not Dict.Exists(Address) Then
Dict.Add Address, SheetName
Else
SheetName = Dict(Address) & "," & SheetName
Dict(Address) = SheetName
End If
End If
Next j
Next i
' Open the workbook with the sheets to be copied as email attachments.
Set SrcWkb = ActiveWorkbook
Set olApp = CreateObject("Outlook.Application")
If Sheets(1).CheckBox1.Value = True Then
For Each Address In Dict.Keys
' Create a new workbook to be used as the attachment.
Set DstWkb = Workbooks.Add(xlWBATWorksheet)
' Copy all the sheets associated with an email to the new workbook.
SheetNames = Split(Dict(Address), ",")
For i = 0 To UBound(SheetNames, 1)
SrcWkb.Worksheets(SheetNames(i)).Copy After:=DstWkb. _
Worksheets(DstWkb.Worksheets.Count)
ActiveSheet.Name = SheetNames(i)
mySheetName = "Tabelle1"
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(mySheetName).Delete
With ActiveSheet
.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues
.Columns("H:H").Select
Selection.NumberFormat = "dd/mm/yyyy"
Range("A1:B1").Select
Selection.Cut Destination:=Range("B1:C1")
Range("A3").Select
Selection.Cut Destination:=Range("E1")
Range("A4").Select
Selection.Cut Destination:=Range("F1")
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Rows("3:3").Select
Selection.AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
End With
Next i
' Save the new workbook in the User's Temp folder.
MName = ActiveSheet.Name & ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Environ("TEMP") & "\" &  _
MName
Application.DisplayAlerts = True
With olApp.CreateItem(0)
.To = Address
.Subject = SubjectLine
.Body = MsgBody
.Attachments.Add DstWkb.FullName, 1, 1
.Display 'send
End With
' Close the new workbook and delete it from the Temp folder.
DstWkb.Close SaveChanges:=False
On Error Resume Next
Kill ThisWorkbook.Path & "\" & ThisWorkbook.Name
Next Address
ElseIf Sheets(1).CheckBox1.Value = False Then
'Das gleiche wie oben, statt .display, .send
End If
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
schon wieder ein Doppler ;-) owT
10.01.2019 16:29:34
robert
Anzeige

317 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige