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
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.
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.
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)
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.
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.
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
'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
