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