merkürdiges Objekt-Problem ...
19.05.2022 12:49:20
Kalle
in den vergangenen Monaten bin ich in vielen Punkten Dank des Archivs und Eurer tollen Hilfe enorm weitergekommen. Dennoch habe ich ein Problem, welches sich mir trotz intensiver Fehlersuche nicht erschließt. Anbei die starkt verschlankte Projektdatei (datenschutzkonform):
https://www.herber.de/bbs/user/153149.xlsm
Funktion: Für die Daten aus "Testbedarf BvB" kann ein Bedarfsraster gebildet werden, welches nur die offene Testdiagnostik ausweist. Diese Anzeige kann in die "TESTPLANUNG" transferiert werden, um dort quasi in der Sandbox weitere Planung vorzunehmen und auf ein kompaktes Format zu reduzieren. Die Planung wird via Email verschickt und vorher ein passender Emailverteiler erzeugt.
Problem: Sind Daten in der "TESTPLANUNG" vorhanden - egal ob 1 Zeile oder 150 -, arbeitet die Sub "Email_Export()" korrekt. Sind aber keine Daten in der "TESTPLANUNG", werden plötzlich zwei Personen/Emails gezählt, die es garnicht geben dürfte.
Da sich um Objekte handelt, übersehe ich bestimmt ein Detail. Ich habe den Code mal kommentiert:
Danke für Eure Hilfe im Voraus! Bin schon so gespannt, woran das nur liegen könnte!?
Kalle
Sub Email_Export()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
Dim rng As Range
Dim lastRow As Long
Dim i As Long
Dim emailList As String
Dim foundEmails As Long
Dim myDictAllEmail As Object
Dim myDictSendEmail As Object
Dim myCell As Range
Dim rngAusbilder As Range
Dim DictKey As Variant
Set myDictAllEmail = CreateObject("Scripting.Dictionary")
Set myDictSendEmail = CreateObject("Scripting.Dictionary")
Set rngAusbilder = Nothing
On Error Resume Next
'Call FreigabeAusschalten
' Email-Quellenangaben laden
With Worksheets("Quellverweise")
lastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
On Error Resume Next ' Wenn der Key bereist existiert einfach ignorieren
For i = 5 To lastRow
myDictAllEmail.Add Key:=.Cells(i, 5).Value, Item:=.Cells(i, 6).Value
Next i
On Error GoTo 0
End With
With Worksheets("Quellverweise")
' Ausbildernamen-Quelle bestimmen
With ActiveSheet
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rngAusbilder = .Range("L6:L" & lastRow).SpecialCells(xlCellTypeVisible)
End With
'Ausbildernamen mit Email abgleichen
On Error Resume Next ' Wenn der Key bereist existiert einfach ignorieren
For Each myCell In rngAusbilder
myDictSendEmail.Add Key:=myCell.Value, Item:=myDictAllEmail(myCell.Value)
Next
On Error GoTo 0
'Listen und Zähler Reset
foundEmails = 0
emailList = ""
'Ausgabe/Abruf des Gesamtverzeichnis
For Each DictKey In myDictSendEmail.keys
emailList = emailList & myDictSendEmail(DictKey) & ";"
foundEmails = foundEmails + 1
'Fehler: wenn keine Daten ab Zeile 5 vorhanden, werden dennoch 2 gezählt ... wo kommen die her?
MsgBox "DictKey aus emailList: " & DictKey
Next
End With
With ActiveSheet
lastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rngAusbilder = .Range("L6:L" & lastRowA).SpecialCells(xlCellTypeVisible)
If MsgBox("Passende Verteiler-Email mit Testgruppenübersicht erzeugen?" & vbCrLf & vbNewLine & _
foundEmails & " Ausbilder(innen) stehen im Verteiler:" & vbCrLf & vbNewLine & _
Replace(emailList, ";", vbCrLf), vbQuestion + vbYesNo, "iTD PLANUNGSASSISTENT") = vbYes Then
Else
Application.EnableEvents = True
Exit Sub
End If
If rngAusbilder Is Nothing Then 'bleibt bislang wirkungslos, obwohl die Range bei blank sheet leer ist
MsgBox "Keine Ausbilder(innen) in der Auswahl gefunden.", vbExclamation, "iTD PLANUNGSASSISTENT"
Exit Sub
End If
End With
'Bild Export
lrv = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set xRg = ActiveSheet.Range("A1:AH" & lrv) '.SpecialCells(xlCellTypeVisible)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "" _
& "" _
& "Liebe Kolleginnen und Kollegen,
" _
& "
" _
& "[PLATZHALTER FÜR INFOTEXT TESTLEITUNG]" _
& "
" _
& "
" _
& "
Freundliche Grüße"
With xOutMail
.Subject = "[PLATZHALTER für BETREFF]"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = emailList
'.Cc = "d.jaeger@xyz.de"
.Display
End With
'Call FreigabeEinschalten
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub