Thema Datum  Von Nutzer Rating
Antwort
01.11.2023 12:32:17 Michael
Solved
01.11.2023 13:24:25 Bernd
NotSolved
01.11.2023 15:37:56 Gast39701
NotSolved
01.11.2023 16:16:27 Bernd
NotSolved
01.11.2023 17:29:21 Gast76851
NotSolved
02.11.2023 10:07:32 Bernd
NotSolved
02.11.2023 10:50:12 Bernd
NotSolved
02.11.2023 13:38:41 Bernd
NotSolved
Rot Sheets per Email verschicken
02.11.2023 13:38:48 Bernd
NotSolved
02.11.2023 13:40:31 Bernd
NotSolved

Ansicht des Beitrags:
Von:
Bernd
Datum:
02.11.2023 13:38:48
Views:
141
Rating: Antwort:
  Ja
Thema:
Sheets per Email verschicken

Hallo Michael. Ich habe das ganze einmal in ein Makro gesetzt.
Wichtig: in dem Ordner in dem du die Sheetstabelle hast musst du einen Ordner Temp erstellen oder den Pfad ändern.
Versuche einfach einmal damit durchzukommen, ansonsten schreib mir.

Gruß Bernd

Ab hier:

   Option Explicit

Sub Mail_senden()

'Starten aus der Persnal.xlsb. Gestartet wird mit offener und aktivierter Quelldatdei (die mit den Sheets)
' In dieser Version ist die Datei mit den Mailadressen fest vergeben.

   
   Dim ws As Worksheet
   Dim i As Integer
   Dim MsgTxt As String
   Dim QName As String
   Dim QSheet As String
   Dim QPath As String
   Dim ZPath As String
   Dim ZName As String
   Dim ZSheet As String
   Dim strBlatt As String
   Dim strDatei As String
   Dim strPfad As String
   Dim outObj As Object
   Dim Mail As Object
   Dim strBodyText As String
   Dim rngDatenQuelleNr As Excel.Range
   Dim rngDatenZielNr As Excel.Range
   Dim Suchwert As String
   Dim Gefunden As Variant
   Dim MailSpalte As String
   Dim Mailadresse As String
   Dim rngDatenZiel As Excel.Range 'Zielrange Wo stehen die Werte die durchsucht werden
   Dim ZZeile As Long

 ZName = ActiveWorkbook.Name 'Erstellt sich aus aktiver Quelldatei (Datei mit den Sheets zum Versand)
 ZSheet = ActiveSheet.Name 'Erstellt sich aus aktiven Quellsheet
 ZPath = ActiveWorkbook.Path 'Erstellt sich aus aktiven Quellpfad
 strPfad = ZPath  '"C:\Temp" 'entsprechend anpassen. Pfad für temporäre Zwischenspeicherung angeben. Ich nutze hierfür einfach den Pfad wo die Sheetstabelle liegt.

QPath = "C:\Test\" 'Pfad zur Datei mit den Mailsheets
QName = "Mailadresssen.xlsx" 'Name der Datei mit den Mailadressen.xls(m)
QSheet = "Adressen" 'Sheet in der die Mailadressen stehen
MailSpalte = "B" ' in dieser Spalte steht die Mailadresse


'Abfrage unbedingt aktivieren, sonst kommst du bei einer Falseingabe nicht mehr heraus und versendest weiß sonst was.
MsgTxt = "Ist das wirklich die Datei deren Sheets du versenden möchtest?" & vbCr & ZName & vbCr & "und das die Tabelle aus der du die Mailadressen bekommst?" & vbCr & QName

If MsgBox(MsgTxt, vbYesNo Or vbQuestion, "ADAM Export") = vbNo Then
       Exit Sub                                 ' 2. weiterbearbeiten =>raus
    End If                                      ' 1. Weiter mit Makro

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXStart der SchleifeXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


'Schleife
i = 1
For Each ws In Worksheets
Sheets(i).Activate


strBlatt = ActiveSheet.Name ' Aktuelles aktives Blatt in neue Arbeitsmappe kopieren

Sheets(strBlatt).Copy ' Gewähltes Tabellenblatt kopieren

ActiveWorkbook.SaveAs strPfad & "\Temp\" & ActiveSheet.Name ' Blatt temporär in vorgegebenes Verzeichnis abspeichern
ZSheet = ActiveSheet.Name 'Erstellt sich aus aktiven Quellsheet
strDatei = ActiveWorkbook.FullName ' Pfad und Dateiname der neuen Datei zwischenspeichern


'Jetzt suchen wir aufgrund des Namens die Mailadresse
Suchwert = ZSheet

  'Sheetnamen in der DatenZiel
  With Workbooks(QName).Worksheets(QSheet) ' mit der Maildatei
    Set rngDatenZiel = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) 'Die Range "A2" bis letzte Zeile in Spalte "A"
  End With

  Gefunden = Application.Match(Suchwert, rngDatenZiel, 0)
  
 If IsNumeric(Gefunden) Then ' Wenn Suchbegriff in Zielsheet vorhanden, dann...
 
    ZZeile = Gefunden + 1 'Ermitteln der Zielzeile +1 weil Start ab A2


Mailadresse = Workbooks(QName).Worksheets(QSheet).Range(MailSpalte & ZZeile)

End If

' Erstellen der Mail
 
'** Mail erzeugen
 Set outObj = CreateObject("Outlook.Application")
 Set Mail = outObj.CreateItem(0)

With Mail
.To = Mailadresse ' & ";deine.Mail@alsKontrolle.com" 'Dies ist, wenn du noch eine 2. Adresse als permanente zuweisen möchtest (z.B.: als Kontrolle oder deinem Chef oder...).
'.CC = ""
.Subject = Workbooks(QName).Worksheets("Mailtext").Range("A1").Value 'Betreff
.BodyFormat = 2 '2 = HTML, 1 = Text
.Attachments.Add strDatei 'Anhang
.Body = Workbooks(QName).Worksheets("Mailtext").Range("A2").Value 'Bodytext / Signatur
End With
 
Workbooks(Dir(strDatei)).Close 'Erzeugte Datei schließen
 
Kill (strDatei) ' Erzeugte Datei wieder löschen
 

Mail.Display        'Erstellt die Email und öffnet diese. Der Versand erfolgt anschließend manuell vom User!
   '.Send        'Sendet die Email automatisch


  i = i + 1
Next

Ende:

   MsgBox "Makro beendet"
End Sub


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
01.11.2023 12:32:17 Michael
Solved
01.11.2023 13:24:25 Bernd
NotSolved
01.11.2023 15:37:56 Gast39701
NotSolved
01.11.2023 16:16:27 Bernd
NotSolved
01.11.2023 17:29:21 Gast76851
NotSolved
02.11.2023 10:07:32 Bernd
NotSolved
02.11.2023 10:50:12 Bernd
NotSolved
02.11.2023 13:38:41 Bernd
NotSolved
Rot Sheets per Email verschicken
02.11.2023 13:38:48 Bernd
NotSolved
02.11.2023 13:40:31 Bernd
NotSolved