VBA - Excel zu PPT Laufzeitfehler
22.07.2021 10:38:36
Dennis
ich bin schon lange fleißiger Leser hier im Forum und konnte schon viele Lösungsvorschläge auf meine Probleme ummodeln.
Leider stehe ich nun vor einem Problem an dem ich schon lange sitze aber nun wirklich ratlos bin und keine Lösung finde.
Ich bin VBA-Anfänger, Hauptsächlich ist es learning bei doing und copy & paste aus dem Forum. Deshalb bitte ich um Nachsicht, wenn mein Code nicht so sauber programmiert ist.
Ich habe einen Excel VBA Code geschrieben, es handelt sich dabei um eine Schleife die für eine variable Anzahl an Projekten Übersichtsfolien erzeugt:
1. Eine Vorgefertigte PowerPoint Folie kopieren, um diese später zu befüllen
2. Ein Excel-Dokument aus dem SharePoint abrufen und die Daten in der Exceldatei zwischenspeichern
3. Bilder vom SharePoint laden bzw. aus Excel übernehmen, auf die Folie kopieren und ausrichtet
4. Übertragen der Projektdaten (Texte, Budget, Daten) auf PowerPoint Folie (in vorhandenen Shapes)
Die Datensammlung und Bildübertragung funktioniert problemlos.
Problem: Bei der Übertragung der Daten aus Excel in die PowerPoint Shapes kommt es immer beim 5. Schleifendurchlauf (5. Folie) zu einem "Laufzeitfehler 13 - Typen unverträglich" . Wenn ich den Debugger starte und den Makro weiter laufen lasse, funktioniert er wieder (Datenverluste treten nicht auf - also werden alle Daten übernommen!). Das Problem tritt dann immer wieder nach ein paar Schleifendurchläufen auf.
Set Textfeld = pptSlide.Shapes("Titel_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U6") Ich hänge den gesamten Code an. Den Problembereich habe ich im unten stehenden Code fett markiert.
Ich habe den Code bereits in verschiedenen Varianten durchlaufen lassen, um einzugrenzen ob es an einem bestimmten Shape liegt, leider tritt der Fehler auch beim Durchlauf mit jedem Shape einzeln (die anderen Datenübertragungen "auskommentiert") in selber Form auf.
Auch die Formatierung der Excel Zellen in verschiedene Formate vor der Datenübertragung hat nichts gebracht.
Verschiedene Versuche mit "On Error Resume Next" und Sprungmarken (GoTo) haben auch nicht funktioniert.
Auch eine 2 sec Pause nach jeder Folie hat nicht geholfen
Ich habe eine halbwegs taugliche Lösung gefunden, die dauerhaft jedoch nicht funktioniert..
Textfeld.TextFrame.TextRange = WSZiel.Range("U6") Textfeld.TextFrame.TextRange.Text = WSZiel.Range("U6").Text
Durch das Einfügen von .Text im Code tritt die Fehlermeldung nicht mehr auf. Das Problem hier ist jedoch, dass die ersten vier Folien flüssig laufen, Excel sich dann jedoch für mehrere Minuten aufhängt und die fünfte Folie erstellt. Ab dieser Folie dauert der Schleifendurchlauf im Schnitt zwei Minuten pro Folie, mit regelmäßigem aufhängen.
Bei 40 Projekten dauert das ganze dann etwa eine Stunde.
Wenn ich den Code ohne .Text laufen lasse, Fehlermeldungen debugge und den Makro weiter laufen lasse bin ich nach ca. 2 Minuten mit der Anzahl an Folien fertig.
Der Makro soll in Zukunft durch verschiedene Personen gestartet werden können. Beide Lösungen sind deshalb leider nicht akzeptabel.
So langsam bin ich Ratlos, Google und die Suchfunktion hier im Forum bringen mich leider auch nicht mehr weiter.
Ich freue mich über jede Hilfe/Idee!
Danke schon im Voraus für das lesen meiner Beschreibung, ich hoffe ich konnte das Problem vernünftig erklären.
Danke und Viele Grüße,
Dennis
Option Explicit
Sub ManagementReporting()
'Makro by Dennis Dahlmann, if you have questions call me
'Variablen
Dim Pfad, PfadI As String
Dim WSZiel As Worksheet
Dim WSQuelle As Worksheet
Dim ProjectNo As String
Dim Bildpfad As String
Dim Bildname As String
Dim x, y
Dim Picture As Object
Dim pptApp As Object, pptPres As Object
Dim chtObj As Object, shp As Object
Dim myShape As Object
Dim pptSlide
Dim Textfeld
Dim Px, Py
Dim i, j, k, l
'---------- Warnung, da Import derzeit sehr lange dauert -------------
' Umstellung Datenübertragung auf .Text um Laufzeitfehler zu meiden, dadurch leider sehr lange laufzeit
If MsgBox("If everything is going well it takes ~10sec per Slide. At the Moment there is a problem with some Project Data Transfer what could lead to a runtime of ~1min per Slide. You cant use Excel and PowerPoint. What do you want?", vbOKCancel, "Start Import?") = vbCancel Then Exit Sub
'------------ Share Point als Laufwerk auf dem PC verbinden ---------
Dim objNetzwerk As Object
Dim strPathSPDrive As String
Dim strPfadSPDrive As String
Dim Drive As String
Set objNetzwerk = CreateObject("WScript.Network")
strPathSPDrive = "https://teams.####.com/####/####/"
' Wenn kein Netzlaufwerk B verbunden ist, wird der SharePoint auf Laufwerk B verbunden
' Ist ein Laufwerk B verbunden, kann der Nutzer entweder abbrechen oder ein anderes
' freies Laufwerk angeben, dass verbunden werden soll
If Not CreateObject("Scripting.FileSystemObject").DriveExists("B") Then
Drive = "B:"
'sharepoint als Laufwerk "B:" verbinden
objNetzwerk.MapNetworkDrive Drive, strPathSPDrive
strPfadSPDrive = "B:\Test\####\"
Else
If MsgBox("Drive B: already exists and the SharePoint can't connect. Press OK to choose another drive or cancel to stop the Makro", vbOKCancel, "Start Import?") = vbCancel Then
Exit Sub
Else
Drive = InputBox("Choose a Drive that is not in use! Format: 'B:'", "Choose Drive to connect SharePoint", "B:")
objNetzwerk.MapNetworkDrive Drive, strPathSPDrive
strPfadSPDrive = Drive & "\Test\####\"
End If
End If
'------------Ende Share Point als Laufwerk auf dem PC verbinden ---------
'---------- Bildschirmaktualisierung ausschalten --------------
Application.ScreenUpdating = False
'------------PowerPoint Präsentation öffnen und Paramter einlesen ---------
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Open("https://teams.####.com/sites/####/Test/####/Reporting.pptx")
'j gibt die Anzahl der Durchläufe an (Der Zellenbezug gibt die Anzahl der eingegebenen Projektnummern aus)
j = Range("W2")
'------------Hier beginnt die Schleife ---------
' 1. PPT Vorlagenfolie wird kopiert
' 2. Projektdaten werden aus dem im SharePoint abgelegten Statusreport geladen
' 3. Projektbild wird aus dem SharePoint geladen und in PPT kopiert
' 4. Die Ampelfarben werden generiert und die Ampeln in PPT kopiert
' 5. Die Projektdaten werden auf die PPT Folie kopiert
' 6. Schleife beginnt neu für nächste Projektnummer
' läuft solange, bis für jede Projeknummer eine Folie existiert
Do Until i = j
' k gibt die Reihennummer in der die nächste Projektnummer steht an
k = 17 + i
' l gibt die Spalte an in der die Projektnummern stehen
l = 2
'i zählt die Anzahl der durchläufe und gibt dadurch die Reihe der nächsten Projektnummer an
i = i + 1
ActiveWorkbook.ActiveSheet.Range("U4") = ActiveWorkbook.ActiveSheet.Cells(k, l)
Set pptSlide = pptPres.Slides(i)
pptSlide.Copy
pptPres.Slides.Paste
'Definition dieser Arbeitsmappe als Ziel der Datenübertragung
Set WSZiel = ActiveWorkbook.ActiveSheet
' Einlesen der Projektnummer zur Pfaderstellung (Range anpassen)
ProjectNo = ActiveWorkbook.ActiveSheet.Cells(k, l)
'------------ Projektdaten aus Statusreport laden ---------
'Pfad der Quelldatai generieren
Pfad = strPfadSPDrive & "\####\" & ProjectNo & ".xlsm"
'Wenn kein Statusreport gefunden wird werden die Zellen geleert, da ansonsten die Informationen
'des vorherigen Projektes stehen bleiben
If Dir(Pfad) = "" Then
WSZiel.Range("W4").Clear
WSZiel.Range("W5").Clear
WSZiel.Range("W6").Clear
WSZiel.Range("W7").Clear
WSZiel.Range("W8").Clear
WSZiel.Range("W9").Clear
WSZiel.Range("W10").Clear
WSZiel.Range("W11").Clear
MsgBox "The Statusreport for Project " & ProjectNo & " was not found!", vbCritical
'Wenn der Statusreport gefunden wird, werden hier die benötigten Informationen kopiert
Else
'Pfad und Datei (Statusbericht) als Quelle der Datenübertragung Definieren und öffnen
Set WSQuelle = Workbooks.Open(Filename:=Pfad, UpdateLinks:=False).Worksheets(1)
'Kopieren der Daten von Quelle (Statusreport) zu Ziel (Dieses Dokument)
'Description and Scope
WSQuelle.Range("B9").Copy Destination:=WSZiel.Range("W4")
'Management Summary
WSQuelle.Range("B15").Copy Destination:=WSZiel.Range("W5")
'Next Milestone
WSQuelle.Range("B12").Copy Destination:=WSZiel.Range("W6")
'Next Milestone end Date
WSQuelle.Range("T12").Copy Destination:=WSZiel.Range("W7")
'Budget
WSQuelle.Range("S35").Copy Destination:=WSZiel.Range("W8")
'Time
WSQuelle.Range("U35").Copy Destination:=WSZiel.Range("W9")
'Scope
WSQuelle.Range("W35").Copy Destination:=WSZiel.Range("W10")
'Date of report
WSQuelle.Range("W6").Copy Destination:=WSZiel.Range("W11")
'Quelle schließen
WSQuelle.Parent.Close savechanges:=False
Set WSQuelle = Nothing
End If
'------------ Projektbild vom SharePoint laden ---------
'Bild vom SharePoint laden, skalieren und in PPT einfügen
'Bilder müssen als .png hochgeladen werden
'Pfad der Quelldatei generieren
Bildpfad = strPfadSPDrive & "\####\" & ProjectNo & ".png"
'Wenn der Pfad existiert und das Bild gefunden wird, wird das Projektbild übernommen
If Dir(Bildpfad) "" Then
'Bild Einfügen
WSZiel.Pictures.Insert(Bildpfad).Select
'Höhe und Breite berechnen und das Bild entsprechend Skalieren
'PPT Feld für Bild: Größe (HxB) = 5,14 x 11,47 -> Verhältnis = 1 : 2,232
'Wenn Bildbreite >= 2,232 x Bildhöhe dann entsprechend der Bildbreite Skalieren
'Ansonsten entsprechend auf die Bildhöhe skalieren
'X= Bildbreite, y=Bildhöhe -> 5,14cm*11,47cm -> ~145px*325px
'Position für das Bild: Top:69Px Left: 358Px
Selection.Name = ProjectNo
With ActiveSheet.Shapes(ProjectNo)
.LockAspectRatio = msoTrue
x = .Width
y = .Height
If x > 2.232 * y Then
x = 325
.Width = x
Else
y = 145
.Height = y
End If
End With
Else
'Wenn kein Bildpfad existiert wurde kein Bild hochgeladen, in diesem Fall wird das #### Logo verwendet
'definition eines anderen Bildpfades
'MsgBox herausgenommen damit der Makro schneller läuft und weniger klicks benötigt -> Info nicht zwingend notwendig!
'MsgBox "No Picture for Project No. " & ProjectNo & " in Database. The #### Logo will be used instead.", vbCritical
Bildpfad = strPfadSPDrive & "\Pictures - Management Reporting\" & "####.png"
Bildname = Bildpfad
'Bild Einfügen
WSZiel.Pictures.Insert(Bildname).Select
'Schritte wie beim Projektbild oben
Selection.Name = ProjectNo
With ActiveSheet.Shapes(ProjectNo)
.LockAspectRatio = msoTrue
x = .Width
y = .Height
If x > 2.232 * y Then
x = 325
.Width = x
Else
y = 145
.Height = y
End If
End With
End If
'Bild übertragen in PPT
Selection.Cut
pptSlide.Shapes.PasteSpecial DataType:=6 '6
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Einlesen der Höhe und Breite
Px = myShape.Width
Py = myShape.Height
'Bestimmung der Position - mittig im grauen Platzhalter mittels der eingelesenen Werte
'Werte fest hinterlegt, bei Änderen der PPT Vorlage das Shape auslesen und Werte anpassen
x = 358 + (325 / 2) - (Px / 2)
y = 63 + (148 / 2) - (Py / 2)
'Set position:
myShape.Left = x
myShape.Top = y
'------------ Ampeln zum Projekstatus entsprechend der Angabe des PM auf die PPT bringen ---------
'Ampelfarben berechnen und einfügen
'Budget
'Abfrage der Ampelfarbe
If Sheets("Management Reporting V2").Range("W8") = "J" Then
x = "AmpelGrün"
Else
If Sheets("Management Reporting V2").Range("W8") = "L" Then
x = "AmpelRot"
Else
x = "AmpelGelb"
End If
End If
Sheets("Management Reporting V2").Shapes.Range(Array(x)).Select
Selection.Copy
'Paste to PowerPoint and position
pptSlide.Shapes.PasteSpecial DataType:=0
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Set position:
myShape.Width = 48.5
myShape.Height = 20
myShape.Left = 299
myShape.Top = 88.5
'Time
'Abfrage der Ampelfarbe
If Sheets("Management Reporting V2").Range("W9") = "J" Then
x = "AmpelGrün"
Else
If Sheets("Management Reporting V2").Range("W9") = "L" Then
x = "AmpelRot"
Else
x = "AmpelGelb"
End If
End If
Sheets("Management Reporting V2").Shapes.Range(Array(x)).Select
Selection.Copy
'Paste to PowerPoint and position
pptSlide.Shapes.PasteSpecial DataType:=0
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Set position:
myShape.Width = 48.5
myShape.Height = 20
myShape.Left = 299
myShape.Top = 138
'Scope
'Abfrage der Ampelfarbe
If Sheets("Management Reporting V2").Range("W10") = "J" Then
x = "AmpelGrün"
Else
If Sheets("Management Reporting V2").Range("W10") = "L" Then
x = "AmpelRot"
Else
x = "AmpelGelb"
End If
End If
Sheets("Management Reporting V2").Shapes.Range(Array(x)).Select
Selection.Copy
'Paste to PowerPoint and position
pptSlide.Shapes.PasteSpecial DataType:=0
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Set position:
myShape.Width = 48.5
myShape.Height = 20
myShape.Left = 299
myShape.Top = 187.5
'------------ Alle Textfelder auf der PPT Folie ausfüllen ---------
' Textfelder übertragen
'Titel der PPT Slide
'WSZiel.Range("U6") = Format(WSZiel.Range("U4") & " - " & WSZiel.Range("U5"), "@")
WSZiel.Range("U6") = WSZiel.Range("U4") & " - " & WSZiel.Range("U5")
WSZiel.Range("U6").NumberFormat = "@"
Set Textfeld = pptSlide.Shapes("Titel_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U6")
'Project Type
Set Textfeld = pptSlide.Shapes("ProjectType_1")
'alte Alternative: Textfeld.TextFrame.TextRange.Text = Sheets("Management Reporting V2").Range("U7")
Textfeld.TextFrame.TextRange = WSZiel.Range("U7")
'Product Segment
Set Textfeld = pptSlide.Shapes("ProductSegment_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U8")
'Textfeld.TextFrame.TextRange.Text = WSZiel.Cells(8, 21)
'Project Manager
Set Textfeld = pptSlide.Shapes("PM_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U9")
'Budget
Set Textfeld = pptSlide.Shapes("Budget_1")
Textfeld.TextFrame.TextRange = Format(WSZiel.Range("U10"), "#,0")
'Actual Costs
Set Textfeld = pptSlide.Shapes("AC_1")
Textfeld.TextFrame.TextRange = Format(WSZiel.Range("U11"), "#,0")
'Start Date
Set Textfeld = pptSlide.Shapes("Start_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U12")
'Planned End Date
Set Textfeld = pptSlide.Shapes("PlanEnd_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U13")
'Est. End Date
Set Textfeld = pptSlide.Shapes("EstEnd_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("U14")
'Datenstand Projektliste
Set Textfeld = pptSlide.Shapes("PL_date")
Textfeld.TextFrame.TextRange = WSZiel.Range("U15")
'Scope/Description
Set Textfeld = pptSlide.Shapes("Scope_Description_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("W4")
'Latest Updates
Set Textfeld = pptSlide.Shapes("status_updates_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("W5")
'Next Milestone
Set Textfeld = pptSlide.Shapes("NextMS")
Textfeld.TextFrame.TextRange = WSZiel.Range("W6")
'Next Milestone Completion/Finish
Set Textfeld = pptSlide.Shapes("MScomp_1")
Textfeld.TextFrame.TextRange = WSZiel.Range("W7")
'Datenstand Projekstatusreport
Set Textfeld = pptSlide.Shapes("PSR_date")
Textfeld.TextFrame.TextRange = WSZiel.Range("W11")
Loop
'Felder aus Statusreport leeren, damit seite vernünftig aussieht
WSZiel.Range("W4").Clear
WSZiel.Range("W5").Clear
WSZiel.Range("W6").Clear
WSZiel.Range("W7").Clear
WSZiel.Range("W8").Clear
WSZiel.Range("W9").Clear
WSZiel.Range("W10").Clear
WSZiel.Range("W11").Clear
'------------ Zurücksetzen paramter Ende Share Point als Laufwerk auf dem PC verbinden ---------
'Sharepoint als Laufwerk trennen, Laufwerk ist als Drive eingelesen (variable) Es wird also einfach das Verbundene Laufwerk eingegeben.
'Der Nutzer bekommt davon nichts mit, außer er hat in Laufwerk B bereits etwas verbunden, dann kann er ein anderes bestimmen
objNetzwerk.RemoveNetworkDrive Drive, True
Set objNetzwerk = Nothing
'----------- Bildschirmaktualisierung einschalten -------------
Application.ScreenUpdating = True
MsgBox ("Your presentation is ready.. Go to the PowerPoint Presentation and 'save as' .. save the presentation local")
Exit Sub
End Sub