Hello,
i wrote a code which should automatically generate an Excel & PowerPoint File for each company we are working with. The CompanyNumber and CompanyName are in an array and the data which alters the about to be copied diagram is in ThisWorkbook.
The code is running fine, although I did not manage to close the opened Workbooks (wb). After executing the Sub CreateMultipleDocs() the Workbooks wb (are still running). I tried tried to narrow the mistake down and it seem to not be able to close the Workbook wb (or wbTemp respecticely) when the macro comes to the Sub CopyPaste and reaches the line where the diagram gets pasted in the PowerPoint. -> marked it in red
I divided the project in MainSubs, so Sub which I need not only for the automation, but also for seperate use (through a button), and in SupportingSubs, which are there to support (Functions & Subs).
I used .UsedContents.Clear and Visible = xlSheetVeryHidden because when I deleted the sheet a microsoft macro security message appeared which collapses the automation.
MainsSubs:
HelpingSubs:Option Explicit Sub CreateMultipleDocs() Call InitProgressBar Application.Visible = True SpeedUp True ' Datum und Zeit Dim t0 As Double Dim Datum As String t0 = CDbl(Now()) Datum = Format(Date, "yyyy/mm/dd") Datum = Replace(Datum, ".", "") ' Deklaration für die k-Schleife Dim CompanyNumber As String Dim Multiple As Boolean ' Excel Dim wbSrc As Workbook Dim wb As Workbook Dim SrcPath As String Set wbSrc = ThisWorkbook SrcPath = wbSrc.Path ' Powerpoint Dim PP As Object Set PP = CreateObject("PowerPoint.Application") Dim PPsrc As Presentation Dim PPpres As Presentation Dim CompanyName As String Set PPsrc = PowerpointFile(PP, SrcPath) ' Array Dim myAr As Variant Dim lenArWith0 As String Dim NumberBanks As Integer NumberBanks = 0 myAr = wbSrc.Sheets("Automation Tool").ListObjects("Dateneingabe").DataBodyRange.Value lenArWith0 = UBound(myAr, 1) - LBound(myAr, 1) + 1 ' Anzahl der tatsächlichen Anzahl an Banken (Leezeilen rausgenommen) Dim i As Integer For i = 1 To lenArWith0 If myAr(i, 1) = Empty Then. NumberBanks = NumberBanks + 1 End If Next Dim DelRoh As Boolean If wbSrc.Sheets("Automation Tool").Range("DelRoh") = "Ja" Then DelRoh = True End If ' Loop Dim k As Integer For k = 1 To lenArWith0 ' CompanyNumber CompanyNumber = myAr(k, 1) CompanyName = myAr(k, 2) ' wenn ein andere Anzeigename gewünscht wurde -> überschreiben If myAr(k, 3) = Empty Then CompanyName = myAr(k, 3) End If ' Order erstellen Dim folderName As String folderName = SrcPath & "\" & Datum & "_" & CompanyName & "-" & CompanyNumber MkDir (folderName) ' Excel CopyAs Dim DateiName As String DateiName = Datum & "_" & CompanyName & "-" & CompanyNumber Set wbSrc = ThisWorkbook wbSrc.SaveCopyAs (folderName & "\" & DateiName & ".xlsm") Application.DisplayAlerts = False ' Application.ScreenUpdating = False ' Application.Visible = False Set wb = Workbooks.Open(folderName & "\" & DateiName & ".xlsm") Application.DisplayAlerts = True ' Application.ScreenUpdating = False ' Application.Visible = False ' PowerPoint CopyAs ' get powerPoint PPsrc.SaveCopyAs (folderName & "\" & DateiName & ".pptx") Set PPpres = PP.Presentations.Open(folderName & "\" & DateiName & ".pptx", WithWindow:=msoFalse) ' Datenanforderung wb.Sheets("Preparing Data").Range("H3") = myAr(k, 1) 'Sheets("Preparing Data") wb.Sheets("Preparing Data").Range("M3") = 0 Calculate Call CopyPaste(wb, PPpres, CompanyName, CompanyNumber) If DelRoh Then Call DelRohdaten(wb) End If ' Fusionpapier ausblenden (False = ausblenden) Call Fusion(wb, False) ' Close Workbook wb.Save wb.Close False PPpres.Save PPpres.Close ' Progress Bar Dim currentProgress As Double Dim BarWidth As Long currentProgress = k / NumberBanks BarWidth = Progress.Border.Width * currentProgress With Progress .Bar.Width = BarWidth .Text.Caption = k & " von " & NumberBanks & " Nutzenrechner (pptx & xlsm) wurden erstellt." .CurrentBank.Caption = CompanyName & " wurde erstellt!" End With DoEvents 'sicherstellen, dass Events immer noch ausgeführt werden können Next ' Loop ' Nachricht, dass es funktioniert hat Unload Progress With Progress .Text.Caption = k - 1 & " von " & NumberBanks & " Nutzenrechner (pptx & xlsm) wurden erstellt." .CurrentBank.Caption = "Die Dateien wurden erstellt und befinden sich in dem Ordner, dieser Excel Datei. Bitte schließen Sie dieses Fenster!" & _ vbCrLf & vbCrLf & "Benötigte Zeit: " & Format(Now - t0, "hh:mm:ss") .Show End With DoEvents 'sicherstellen, dass Events immer noch ausgeführt werden können ' MsgBox "Es wurden " & k - 1 & " Ordner mit jeweils einer Excel Datei und einer PowerPoint Datei erstellt!" & vbCrLf & vbCrLf & _ "Diese befinden sich in dem gleichen Ordner, wo die Excel lag, von der dieses Makro ausgeführt wurde." & vbCrLf & vbCrLf & "Benötigte Zeit: " _ & Format(Now - t0, "hh:mm:ss"), vbInformation, "Auswertung abgeschlossen" '& Chr(13) & PP.Quit ' Progress Bar ausschalten Unload Progress SpeedUp False Application.Visible = True End Sub Sub UpdateMyDiagram() Dim PP As Object Dim PPpres As Presentation Set PP = CreateObject("PowerPoint.Application") Dim wb As Workbook Dim CompanyNumber As String Set wb = ThisWorkbook Set PPpres = PowerpointFile(PP, ThisWorkbook.Path) Call CopyPaste(wb, PPpres) MsgBox "Die MyDiagram wurde aktualisiert" End Sub Sub DelRohdatenOfThisWB() Call DelRohdaten(ThisWorkbook) End Sub Sub FusionYes(Optional wb As Workbook) If wb Is Nothing Then Set wb = ThisWorkbook End If With wb .Sheets("Fusion").Visible = True .Sheets("Zins").Visible = True .Sheets("Preparing Data").Columns("L:L").EntireColumn.Hidden = False .Sheets("Preparing Data").Columns("N:N").EntireColumn.Hidden = False End With End Sub Sub FusionNo(Optional wb As Workbook) If wb Is Nothing Then Set wb = ThisWorkbook End If With wb .Sheets("Fusion").Visible = False .Sheets("Zins").Visible = False .Sheets("Preparing Data").Columns("L:L").EntireColumn.Hidden = True .Sheets("Preparing Data").Columns("N:N").EntireColumn.Hidden = True End With If unlocked Then wb.Sheets("MyDiagram").Activate End If End Sub
Public Sub Fusion(wbTemp As Workbook, IsFusion As Boolean) If IsFusion Then Call FusionYes(wbTemp) Else Call FusionNo(wbTemp) End If End Sub Public Sub CopyPaste(wbTemp As Workbook, PPpresTemp As Presentation, Optional CompanyNameTemp As String, Optional CompanyNumberTemp As String) 'Declare variables Dim ppSlide As Slide Dim myShape As Object Dim objCh As Object Dim MyChartName As String ' SLIDE 1 ' Delete charts Set ppSlide = PPpresTemp.Slides(1) MyChartName = "MyDiagram" For Each objCh In ppSlide.Shapes If objCh.Name = MyChartName Then objCh.Delete End If Next ' copy from Excel Application.CutCopyMode = False wbTemp.Sheets("MyDiagram").ChartObjects("MyDiagram").Copy ' paste to PPT Set myShape = PPpresTemp.Slides(1).Shapes.Paste 'Special(DataType:=ppPasteDefault) '11 = ppPasteShape 2 = ppPasteEnhancedMetafile Application.CutCopyMode = False With myShape .Left = 3 .Top = 130 .Width = 932 End With If CompanyNameTemp = "" Then CompanyNameTemp = wbTemp.Sheets("Preparing Data").Range("H4").Text End If If CompanyNumberTemp = "" Then CompanyNumberTemp = wbTemp.Sheets("Preparing Data").Range("H3").Text End If PPpresTemp.Slides(1).Shapes("Name").TextFrame.TextRange.Text = CompanyNameTemp & " (CompanyNumber: " & CompanyNumberTemp & ") - " _ & Sheets("MyDiagram").Range("X8").Text ' SLIDE 2 ' Delete charts Set ppSlide = PPpresTemp.Slides(2) MyChartName = "My2ndDiagram" For Each objCh In ppSlide.Shapes '(ppSlide.Shapes.Count) If objCh.Name = MyChartName Then objCh.Delete End If Next ' copy from Excel Application.CutCopyMode = False wbTemp.Sheets("My2ndDiagram").ChartObjects("My2ndDiagram").Copy ' paste to PPT Set myShape = PPpresTemp.Slides(2).Shapes.PasteSpecial(DataType:=ppPasteDefault) Application.CutCopyMode = False With myShape .Left = 26 .Top = 175 End With End Sub Public Sub DelRohdaten(wbTemp As Workbook) ' hardcode formulas wbTemp.Sheets("Preparing Data").Range("H3:H53") = wbTemp.Sheets("Preparing Data").Range("H3:H53").Value wbTemp.Sheets("Preparing Data").Range("M3:M53") = wbTemp.Sheets("Preparing Data").Range("M3:M53").Value ' löschen der Sheets wbTemp.Sheets("data2").UsedRange.Clear wbTemp.Sheets("data2").Visible = xlSheetVeryHidden wbTemp.Sheets("data").UsedRange.Clear wbTemp.Sheets("data").Visible = xlSheetVeryHidden wbTemp.Sheets("MyDiagram").Activate wbTemp.Sheets("Automation Tool").Visible = xlSheetVeryHidden wbTemp.Sheets("Preparing Data").Visible = xlSheetVeryHidden wbTemp.Sheets("MyDiagram").Activate End Sub Public Sub InitProgressBar() With Progress .Bar.Width = 0 .CurrentBank = "Die Dokumente befinden sich nach Ausführung des Makros in dem Dateipfad der Exceldatei." .Text.Caption = "0 Nutzenrechner (pptx & xlsm) wurden erstellt" .Show vbModeless End With End Sub Public Sub SpeedUp(SpeedUpOn As Boolean) With Application If SpeedUpOn Then .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayStatusBar = False 'in case you are not showing any messages Else .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayStatusBar = True End If End With End Sub Public Function PowerpointFile(PPtemp As Object, SrcPath As String) As Presentation Dim ppFileName, pptpath As String Dim PPpresTemp As Presentation pptFileName = Dir(SrcPath & Application.PathSeparator & "*.pptx") pptpath = SrcPath & Application.PathSeparator & pptFileName Set PPpresTemp = GetPowerpointFileIfOpen(PPtemp, pptpath) If PPpresTemp Is Nothing Then Set PPpresTemp = PPtemp.Presentations.Open(pptpath, WithWindow:=msoFalse) End If Set PowerpointFile = PPpresTemp End Function Public Function GetPowerpointFileIfOpen(PPtemp As Object, pptpath As String) As Object For Each p In PPtemp.Presentations If p.FullName = pptpath Then Set GetPowerpointFileIfOpen = p Exit Function End If Next p End Function
