o0omax
08-12-2022, 10:11 AM
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:
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
Else
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
Else
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
HelpingSubs:
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
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:
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
Else
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
Else
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
HelpingSubs:
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