Bestimmten Bereich in E-Mail versenden

[Iceslayer]

Hallo Miteinander,

stehe vor einer mir schwierig vorkommenden Herausforderung.
Ich versuche aus einer Excel Arbeitsmappe eine Mail zu generieren, das funktioniert grundsätzlich, nur sieht diese Liste in etwa so aus.

   
Diese Liste ändert sich aber ständig (Jede Woche ca.) und somit hat sie keine feste Formatierung wie sie aussieht.

Ich möchte also irgendwie an den Zuständigen Sachbearbeiter eine Mail generieren mit dem Inhalt der Excel Tabelle (Einfach Kopieren).
Also müsste ich irgendwie dem Makro sagen, dass es solange den Bereich kopiert bis ein neuer Sachbearbeiter auftritt.
Soweit bin ich Gedanklich ja schon nur die Umsetzung fehlt.
Habt ihr da vlt. eine Idee oder gar eine Lösung?
Freue mich auf Rückmeldung


schöne Grüße,
Thomas

[Mase]

Hi,

wenn ich richtig verstanden habe:

a) Filter die Liste nach Sachbearbeiter
b) Setze das Filtrat in ein RangeObjekt
c) verwende die RangeToHtml-Funktion von https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Et violà !

[Iceslayer]

Hallo Mase,

danke für die schnelle Rückmeldung.
Die Liste nach Sachbearbeitern zu Filtern mache ich bereits.
Ich kann dir leider bei Punkt 2 nicht ganz folgen was du mit "Filtrat" meinst.
Ich schau mir mal die Funktion RangeToHtml an bisher habe ich davon noch kein Gebrauch gemacht.

Wenn du vlt. einen kleinen Beispiel Code hättest wäre mir sehr Geholfen.


schöne Grüße,
Thomas

[Mase]

zu b)

klicke A1 an

geh auf Daten -> Filtern

setze in Spalte D den Filter -> 23

Das Ergebnis (Filtrat) was angezeigt wird, ist das, was Du (vermutlich) in Deiner Mail an den Sachbearbeiter 23 bzw 23@test.de schicken möchtest.

[Iceslayer]

Okay dass verstehe ich soweit.
Aber ungeklärt ist noch ob dieser Vorgang auch Automatisch für jeden Sachbearbeiter geht.
Heißt also:
Liste wird aus einer SQL abfrage Erstellt -> Makro soll ausgeführt werden -> Liste soll nach Sachbearbeiter gefiltert werden -> E-Mail's an alle Sachbearbeiter mit Inhalt senden -> Mappe Schließen

aber da diese Liste Woche für Woche anders aussehen kann bin ich am Rätseln wie ich es schaffe dies so hinzubekommen.

[Mase]

Liste wird aus einer SQL-Abfrage erstellt?

Noch besser, falls du via ADODB auf die Datenbank aus Excel zugreifen kannst:

a) Array an Sachbearbeiter definieren
b) Recordset mit Sachbearbeiter-manipuliertem SQL-Statement aus einer Schleife absetzen
c) Rückgabewert des Recordset in ein Array -> bzw .Body der Message

Et violà !


Falls kein ADODB:
a) Menge an Sachbearbeiter definieren (also Nummern)
b) Nummern in einer Schleife als Filter setzen
c) prüfen ob Filtrat Daten enthält
d) weiter mit Post #2 ab b)

[Iceslayer]

Leider sagt mir ADODB nichts....vlt. such ich mal danach und kann es dann iwie zusammenbasteln.

Die Lösung mit der Schleife hört sich bisher sehr gut an zusammen mit einer prüfung ob text vorhanden ist sollte dies kein problem sein.
Gibt es möglicherweise einen einfacheren weg eine E-Mail zu generieren? Müsste mir das RangeToHtml erstmal anschauen.

Danke schonmal
Gruß
Thomas

[Mase]

Verstehe.

Dann mach mal aus dem Bild ne Exceldatei und Ich unterstütze Dich bei der Umsetzung.

[Iceslayer]

Oh wow das wäre der Wahnsinn.

hab dir die Test Excelmappe angehängt.
  Projektdaten Test.xlsx (Größe: 10,82 KB / Downloads: 5)
Die versendung der Mails sollte über Outlook stattfinden.

Danke Vielmals.

Gruß
Thomas

[Mase]

Hi,

anbei der Code bzw Anhang zum testen:

Code:

Option Explicit
Private olApp As Object
Private olMail As Object

Const m_sWksFilter As String = "E-Mails"
Const m_sWksProjektdaten As String = "Projektdaten"

Sub IceSlayer()
    Dim wkb As Workbook
    Dim wks As Worksheet, wksProjektdaten As Worksheet
    Dim arr() As Variant
    Dim rng As Range, rngHTML As Range
    Dim i As Long
    '
    On Error GoTo err
    '
    Call TurnOffFunctionality
    '
    Set wkb = ThisWorkbook
    Set wks = wkb.Worksheets(m_sWksFilter)
    Set wksProjektdaten = wkb.Worksheets(m_sWksProjektdaten)
    '
    'Sachbearbeiter in Array
    With wks
        Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 2))
        arr = rng
    End With
    '
    'Filter setzen
    With wksProjektdaten
        If .AutoFilterMode = True Then
            .AutoFilter.ShowAllData
        ElseIf .AutoFilterMode = False Then
            .Range("A1").AutoFilter
        End If
    End With
    '
    'Range nach Sachbearbeiter sortieren
    Call SortAutoFilter(wksProjektdaten, wksProjektdaten.Range("D1:D19"))
    '
    'Emails erzeugen; .Display
    For i = LBound(arr, 1) To UBound(arr, 1) Step 1
        
        With wksProjektdaten
            'Range nach Sachbearbeiter filtern
            .Range("A1").AutoFilter Field:=4, Criteria1:=arr(i, 1)
            'prüfen, ob Filterergebnis leer
            Set rngHTML = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
            With rngHTML
                If .Cells.Count > 4 Then 'nur überschrift = 4; sonst vielfaches von 4
                    Call createMails(rngHTML, arr(i, 2))
                End If
            End With
            .ShowAllData
        End With
        
    Next
    
    
    '
err:
    If err.Number <> 0 Then
        MsgBox err.Number & vbCrLf & err.Description
    End If
    Call TurnOnFunctionality
    Set wks = Nothing: Set wksProjektdaten = Nothing: Set wkb = Nothing: Set olMail = Nothing: Set olApp = Nothing
End Sub

Sub SortAutoFilter(wks As Worksheet, rngSort As Range)
    With wks
        .AutoFilter.Sort.SortFields.Clear
        .AutoFilter.Sort.SortFields.Add Key _
        :=rngSort, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    End With
    With wks.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Sub createMails(rng As Range, ByVal sRecipient As String)
    '
    On Error Resume Next
    '
    Set olApp = GetObject(, "Outlook.Application")
    If err.Number = 429 Then
        err.Clear
        Set olApp = CreateObject("Outlook.Application")
        If err.Number = 429 Then
            err.Clear
            MsgBox "Excel installiert ?", vbCritical + vbOKOnly, "Author informiert:"
            Exit Sub
        End If
    End If
    
    '
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
    .To = sRecipient
    .HTMLBody = RangetoHTML(rng)
    .Display
    End With
End Sub
Public Sub TurnOffFunctionality()
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
End Sub
Public Sub TurnOnFunctionality()
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub