Makro: Email an Email-Adressen aus Excel Tabelle über Schaltfläche schicken?
Hallo,
Ausgangssituation: ich habe eine Excel-Tabelle mit verschiedenen Daten von Personen, unteranderem auch in mehreren Spalten Email-Adressen.
Ich möchte über eine Schaltfläche, dass sich automatisch ein Nachricht versenden Fenster von Outlook öffnet mit allen Email Adressen aus der Excel-Tabelle. Zuvor müssten jedoch Duplikate entfernt werden
ist das möglich? und wenn ja wie?
2 Antworten
Ist das die Folgefrage zum Suchen der E-Mail Adressen?
Sub suche2()
Dim rCell As Range
Dim rRng As Range
Dim quelle As String
Dim mails As String
quelle = "Tabelle2"
Set rRng = Sheets(quelle).Range("A1:C10")
For Each rCell In rRng.Cells
If InStr(1, rCell, "@", vbTextCompare) > 0 And InStr(1, mails, rCell, vbTextCompare) = 0 Then mails = mails & ";" & rCellNext rCell
Dim olapp As Object
Set olapp = CreateObject("Outlook.Application")
With olapp.CreateItem(0) .to = mails .Save
End With
MsgBox ("Schau in Deine Outlook Entwürfe")
End Sub
Die Aussage wird nicht mehr in die Tabelle geschrieben, sondern direkt in Outlook.
Wenn es Dir lieber ist, vorher noch in Excel kontrollieren zu können, dann kannst Du auch die Variante nehmen: Die schreibt die Gesamtliste der Namen mit ; getrennt in ein festgelegtes Feld (in meinem Beispiel Tabelle4 A1 -> Tabelle4.cells(1,1).value was Du beliebig anpassen kannst)
Sub suche3()
Dim rCell As Range
Dim rRng As Range
Dim quelle As String
Dim mails As String
quelle = "Tabelle2"
Set rRng = Sheets(quelle).Range("A1:C10")
For Each rCell In rRng.Cells
If InStr(1, rCell, "@", vbTextCompare) > 0 And InStr(1, mails, rCell, vbTextCompare) = 0 Then mails = mails & ";" & rCellNext rCell
Tabelle4.cells(1,1).value=mails
End Sub
Sub suche3()
Dim rCell As Range
Dim rRng As Range
Dim quelle As String
Dim mails As String
quelle = "Tabelle2"
Set rRng = Sheets(quelle).Range("A1:C10")
For Each rCell In rRng.Cells
If InStr(1, rCell, "@", vbTextCompare) > 0 And InStr(1, mails, rCell, vbTextCompare) = 0 Then mails = mails & ";" & rCell
Next rCell
Tabelle4.cells(1,1).value=mails
End SubDa war ein Zeilenumbruch falsch
ich habe jetzt dieses makro. leider weiß ich nicht wie ich da bei"senden an" die email adressen aus der excel tabelle einfügen lassen kann. wie gebe ich da an dass er nach allen worten mit dem "@" suchen soll und die da mit ";" eintragen soll?
Sub EMail()
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.Display
.To = ???
.CC = "" 'Optional Kopie an
.BCC = "" 'Optional Bliendkopie an
.Subject = "HotNews"
.Body = "Hallo!" & vbCrLf & vbCrLf & "Gruß," & " " & Application.UserName
End With
End Sub
Dafür hatte ich ja zwei Varianten beschrieben. Suche2 legt die zusammenkopierten E-Mail Adressen in den Entwurf ab, Suche3 speichert den Wert in der Exceltabelle (also einfach rauskopieren und manuell in Outlook einfügen).
Was genau funktioniert denn bei den beiden Varianten nicht? Wenn die den Code in Visual Basic hast und mit F8 Zeile für Zeile durchgehst, müsste er bei irgendeiner Zeile eine Fehlermeldung ausgeben. Wo und was meckert das Programm genau an? Bei Suche3 musst Du nur drei Dinge anpassen:
- Wie heißt das Tabellenblatt in dem die E-Mail Adressen zu suchen sind?
- In welchem Bereich stehen diese?
- Wo soll das Ergebnis gespeichert werden.
Die drei Punkte sind fett markiert:
Sub suche3()
Dim rCell As Range
Dim rRng As Range
Dim quelle As String
Dim mails As String
quelle = "Tabelle2"
Set rRng = Sheets(quelle).Range("A1:C10")
For Each rCell In rRng.Cells
If InStr(1, rCell, "@", vbTextCompare) > 0 And InStr(1, mails, rCell, vbTextCompare) = 0 Then mails = mails & ";" & rCell
Next rCell
Tabelle4.cells(1,1).value=mails
End Sub
hmm. irgendwie passiert hier nichts wenn ich auf die Schaltfläche dann klicke :(