Gefilterte Tabelle via Email senden
#1
Hallo zusammen, 

ich habe für meine Erfahrungen eine gefühlte Mammut Aufgabe und leider nichts wirklich passendes bis lang gefunden. 
Nun seit ihr meine Hoffnung. Ich kenne mich bereits ein wenig mit Formeln und co aus, aber auf diesem Gebiet bin ich absoluter Neuling.

Hier meine Wunschvorstellung: 

Ich habe eine Datei (hier angehangen als Beispiel.xlsx).
Dort stehen in einer Tabelle mehrere Nutzer mit verschiedenen Daten und Beispiel Datum.

Die Aufgabe besteht nun darin, diesen Nutzer, die Daten aus den Spalten Datum bis Feld 3 via Email zuzusenden.
Am besten in dem Format, wie Sie auch in der Tabelle stehen. Allerdings gibt es ein paar Kriterien:

- Es sollen nur die Daten gesendet werden, die in einem gefilterten Datum liegen (ein oder mehrere Tage). Die Filter werden entsprechend über die Datenschnitte gesetzt.
- Es soll jeder Nutzer nur seine Daten von diesem Tag erhalten. Als Beispiel: Ich klicke auf den 29. Dez. Diese Daten sollen nun an die jeweiligen Nutzer gesendet werden.
-> Nutzer 1 soll die Tabelle mit den Spalten Datum bis Feld 3 erhalten und die beiden Zeilen in denen er notiert ist
-> Nutzer 2 und 3 sollen das gleiche mit Ihren Daten bekommen
-> keiner der Nutzer soll die anderen Daten der anderen beiden sehen

Die Mails sollten sofern möglich auf einmal an alle 3 Nutzer geschickt werden. Am Anfang gern als geöffnete Email die manuell geschickt werden muss. Sofern ich sichergehen kann das alles funktioniert,
können diese Emails dann auch ohne meine Bestätigung verschickt werden.

Die gewünschte Email-Vorlage hab ich auch nochmal als Screenshot angehangen.

Zum Hintergrund, es geht hier in meiner Praxis natürlich nicht um 1-4 Personen sondern hunderte. Durch diese Automatisierung erhoffe ich mir einen enormen Zeitvorteil, 
da ich die Daten nicht nach Nutzer filtern und manuell in die Email kopieren muss.

Ich hoffe ich konnte euch meinen Traum etwas näher bringen und Ihr habt Ideen, wie ich dies (vielleicht auch nur in Teilen) umsetzen kann.

Lieben Gruß,
Ronny

PS: Gerade bemerkt, dass am 29. Dez Nutzer 2 gar nicht auftaucht :D Überschreibt einfach einmal Nutzer 3 auf Nutzer 2 dann passt meine Schilderung oben wieder. Entschuldigung dafür.
Antworten Top
#2
Halo Ronny,

hier mal ein Ansatz, eine Idee, wie Du das angehen könntest.

Derzeit wird jedoch immer nur an den einen Empfänger gesendet, der als erstes sichtbar ist.

Wenn eMails an alle sichtbaren Empfänger getrennt und in einem Rutsch gesendet werden sollen, muss das in einer Schleife mit erweitertem Code ablaufen.
Dafür habe ich gerade keine Zeit mehr.

Eine Mammutaufgabe eben.

Schau einfach mal, ob Du damit schon etwas anfangen kannst....

Code:

Option Explicit
Option Compare Text

Sub Mail_Senden()
'Sendet Mail mit integriertem Bereich als Bereich mit Signatur
  Dim WSh As Worksheet
  Dim sMailtext As String, sSignatur As String
  Dim sBer As String, iEinf As Integer, iZeile As Long
 
  Set WSh = ThisWorkbook.Sheets("Beispiel")     'Blatt mit Maildaten und Daten
  iZeile = WSh.Cells(Rows.Count, "B").End(xlUp).Row   'Letzte Zeile in Spalte
  sBer = "D5:G" & iZeile                        ' Kopierbereich
 
  For iZeile = 6 To iZeile                      ' erste relevante Zeile ermitteln
      If WSh.Rows(iZeile).Hidden = False Then Exit For
      If WSh.Cells(iZeile, "C") = "" Then Exit Sub
  Next iZeile
 
  WSh.Range(sBer).Copy                          ' Bereich kopieren
 
  With CreateObject("Outlook.Application").CreateItem(0)
     .BodyFormat = 2                            '2=HTML-Format, 3=Richtext
     .Subject = "Ihre Daten vom " _
              & WSh.Cells(iZeile, "D").Value    ' Betreff
     .To = WSh.Cells(iZeile, "C").Value         ' Empfänger
'    .Cc = WSh.Cells(iZeile, "C").Value         ' Kopie
      sMailtext = "Hallo " _
                & WSh.Cells(iZeile, "B").Value & "," & vbLf & vbLf _
                & "anbei Deine Daten:" & vbLf & vbLf
     .Getinspector:  sSignatur = .htmlbody      ' Signatur holen
     .htmlbody = Replace(sMailtext, vbLf, "<br>") & .htmlbody
     .Display
  
     iEinf = Len(sMailtext)                     ' Grafik Einfügestelle
    
     With .Getinspector.WordEditor.Application.Selection
         .Start = iEinf: .End = iEinf
         .Paste                                 ' Bereich in Mail einfügen
     End With
 
 End With

End Sub

_________
viele Grüße
Karl-Heinz
[-] Folgende(r) 1 Nutzer sagt Danke an volti für diesen Beitrag:
  • WutKnut
Antworten Top
#3
Hallo Karl Heinz, 

vielen Dank für deine Rasche Antwort. 

Ich habe etwas mit deiner Vorlage herum experimentiert (Texte, Spalten etc angepasst) und bin schon wieder schier begeistert von dir!

Es tut grundlegend genau das was du gesagt hast und was es tun soll. Email geht auf, Text geht rein und ich kann es abschicken.
Einziger "Minuspunkt" ist, dass Zeitrahmen im Subject nicht gesetzt werden sondern immer nur das jüngste Datum. 
Hier möchte ich mich aber nicht beschweren, da dies jammern auf hohem Niveau wäre :D

Wie ich die Emails nun verschicken kann ohne das Outlook erst auf geht versuche ich allein herauszufinden.
Sofern du Zeit hast die "Upgrade"-Version zu basteln (und ich diese hoffentlich auch verstehe) wär das natürlich Mega.

Noch einmal vielen lieben Dank und schon einmal einen Guten Rutsch ins neue Jahr! (natürlich auch den fleißigen Rest hier).

Grüße,
Ronny
Antworten Top
#4
Hallo Ronny,

zunächst einmal wünsche ich ein gutes und gesundes Jahr 2021.

Hier noch mal ein Update, mit dem es möglich ist, auch mehrere Mails automatisiert zu erstellen.

Hierzu einfach im Datenschnitt die gewünschten Nutzer auswählen und den Button klicken.

Ohne, dass Outlook aufgeht, wird es nicht funktionieren.

Du kannst die Schrift auch formatieren....

viele Grüße
Karl-Heinz


Angehängte Dateien
.xlsm   Beispieldatei_eMailversand.xlsm (Größe: 38,12 KB / Downloads: 13)
Antworten Top
#5
Question 
Hallo Karl-Heinz, 

vielen Dank für deine Mühen. Ich habe in deine Datei mal reingeschaut aber noch nicht auf meine originale angewand.
(Werde ich aber so bald wie möglich tun).

Wegen dem senden: Outlook ist die ganze Zeit geöffnet. 

Ich habe auch mit dem .sent befehl experimentiert. Da versendet er die Emails zwar, aber irgendwie kopiert er nicht die Werte in die Email.
Der Rest (Email-Adresse, Name, Text und selbst die Signatur) sind in der Email enthalten. Nach langen Kopfschütteln und mich selbst fragen bin ich dann erst einmal ins Wochenende gestartet :D

Wenn du noch eine Idee hast, wo ich den .sent Befehl einbauen kann wäre dies ein Traum.
Sobald ich dein Macro auf die original-Datei angewendet habe gibts auch wieder eine Rückmeldung.

Danke noch einmal, dass du dir die Zeit genommen hast!

Besten Gruß,
Ronny
Antworten Top
#6
Hallo Ronny,

bei mir läuft es problemlos. Vielleicht sind bei Dir auch Zeitprobleme.

Hier mal ein etwas erweiterter Code mit Zeitverzögerung und Fehlerabfang bzgl. des Kopierens und Einbau des .Sent.

Code:

Option Explicit
Option Compare Text

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Mail_Senden()
' Abarbeiten der einzelnen, gewünschten Mails lt. Filter
  Dim oSI As Object
  Dim i As Integer, sItems As String, sArr() As String
  
  With ActiveWorkbook.SlicerCaches("Datenschnitt_Name")
     For Each oSI In .SlicerItems
         If oSI.Selected = True Then
            sItems = sItems & oSI.Name & ","        ' gewünschte Nutzer sammeln
         End If
     Next oSI
     If sItems = "" Then Exit Sub
     sArr = Split(sItems, ",")                      ' Daten ins Array
  
     For i = 0 To UBound(sArr) - 1
        .ClearManualFilter                          ' Filter zurück setzen
        For Each oSI In .SlicerItems                ' Alle Items durchgehen
           If Not sArr(i) Like oSI.Name Then
              oSI.Selected = False                  ' Item abwählen
           End If
        Next oSI
        Mail_SendenEx                               ' Jetzt die Mail erstellen
     Next i
  End With
End Sub

Sub Mail_SendenEx()
'Sendet Mail mit integriertem Bereich als Bereich mit Signatur
  Dim WSh As Worksheet, sBer As String
  Dim sMailtext As String, sBetreff As String, sEmpfaenger As String
  Dim iEinf As Integer, iZeile As Long, iBeginn As Long, iEnde As Long
 
  Set WSh = ThisWorkbook.Sheets("Beispiel")         ' Blatt mit Maildaten und Daten
  iZeile = WSh.Cells(Rows.Count, "B").End(xlUp).Row ' Letzte Zeile in Spalte
 
  For iZeile = 6 To iZeile                          ' erste relevante Zeile ermitteln
      If WSh.Rows(iZeile).Hidden = False Then
         If InStr(sEmpfaenger, WSh.Cells(iZeile, "C").Value & ";") = 0 Then
            sEmpfaenger = sEmpfaenger & WSh.Cells(iZeile, "C").Value & ";"
         End If
         If iBeginn = 0 Then iBeginn = iZeile
         iEnde = iZeile
      End If
  Next iZeile
  If sEmpfaenger = "" Then Exit Sub                 ' Kein Empfänger =>raus
  sEmpfaenger = Left$(sEmpfaenger, Len(sEmpfaenger) - 1)
  
  sBer = "D5:G5,D" & iBeginn & ":G" & iEnde         ' Kopierbereich setzen
  WSh.Range(sBer).Copy                              ' Bereich kopieren
 
  With CreateObject("Outlook.Application").CreateItem(0)
     .BodyFormat = 2                                ' 2=HTML-Format
      sBetreff = WSh.Cells(iBeginn, "D").Value      ' Betreff zusammenbauen
      If sBetreff <> WSh.Cells(iEnde, "D").Value Then
         sBetreff = WSh.Cells(iEnde, "D").Value _
                  & " bis zum " & sBetreff
      End If
     .Subject = "Ihre Daten vom " & sBetreff        ' Betreff
     .To = sEmpfaenger                              ' Empfänger
      
      With WSh.Cells(iBeginn, "A")
           sMailtext = "Sehr geehrte" & IIf(.Value = "Herr", "r ", " ") _
                     & .Value & " " _
                     & .Offset(, 1).Value & "," _
                     & "Anbei Ihre Daten:"
      End With
      
      iEinf = Len(sMailtext)                        ' Grafik Einfügestelle
      sMailtext = "<body style='font-family:Arial; font-size:10pt;color:#000000'>" _
                & sMailtext & "</body>"             ' Schrift formatieren
     .Getinspector:                                 ' Signatur holen
     .htmlbody = Replace(sMailtext, "", "<br>") & .htmlbody
     .Display                                       ' Mail anzeigen
  
     On Error Resume Next
     Do
       Err = 0
       Sleep 100
       WSh.Range(sBer).Copy                         ' Bereich kopieren
       If Err = 0 Then Exit Do
     Loop
    
     With .Getinspector.WordEditor.Application.Selection
          .Start = iEinf: .End = iEinf
          .Paste                                    ' Bereich in Mail einfügen
     End With
    
     .sent                                          ' Mail absenden
  
 End With

End Sub

_________
viele Grüße
Karl-Heinz
Antworten Top
#7
Moin Karl-Heinz!
Tippfehler:
.Send statt .Sent

Gruß Ralf
Gib einem Mann einen Fisch und du ernährst ihn für einen Tag. 
Lehre einen Mann zu fischen und du ernährst ihn für sein Leben. (Konfuzius)
[-] Folgende(r) 1 Nutzer sagt Danke an RPP63 für diesen Beitrag:
  • volti
Antworten Top
#8
Jo Ralf. danke für den Hinweis.

Einfach aus dem vorherigen Beitrag abgeschrieben und nicht weiter nachgedacht. 

VG KH
Antworten Top
#9
Hallo zusammen, 

ich wollte kurz nochmal ein Lebenszeichen von mir geben :)
Ich hab es leider noch nicht zeitlich geschafft das 2te Makro einzuarbeiten.
Das erste jedoch funktioniert super und die Senden-Funktion nun auch.
Ich hatte den Fehler gemacht, das .display auszukommentieren

Ich melde mich noch einmal wenn ich den zweiten Code übernommen habe.
Antworten Top
#10
Danke für die Rückmeldung Ronny, das ist lieb.

Man  will ja auch wissen, ob's was gebracht hat 19

Und viel Erfolg noch.

viele Grüße
Karl-Heinz
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste