BVAmateur_12
11-15-2021, 02:54 AM
Hi all,
I have a Macro which loops through the master data in a workbook and exports all that graphs + tables associated with each of the numbers into PowerPoint. The issue with this is the loop has about 80 or so numbers in therefore left unchecked it can be running for a while.
I'm looking for a way to simply 'stop' the Macro running, e.g. by another button, instead of opening up the editor and pressing 'Stop' each time.
Anyone know an easy way to do this? Code is below:
Sub UK_Export_Sales_and_HDA_and_Forecast()
'Declare Powerpoint Object Variables
Dim PPTSlide As Object
'Animate Full
Dim i As Integer
'Declare Excel Object Variable
Dim Chrt As ChartObject
'Declare text box as shape
Dim objTextBox As Shape
'Declare Excel Cell Variables
Dim ExcRng As Range
' Reference existing instance of PowerPoint
Set PPApp = GetObject("", "Powerpoint.Application")
PPApp.Activate
On Error GoTo 10
15 Set PPPres = PPApp.ActivePresentation
slidecount = PPPres.Slides.Count
GoTo 20
10 PPApp.Presentations.Add
GoTo 15
20 SldIndex = 1
'Create reference to chart to export
Set Chrt = Sheets("Export Chart to PPT").ChartObjects(1)
'***NEW
Set ChrtHDA = Sheets("Export HDA Forecast").ChartObjects(1)
'Stop Now Parameter
StopNow = False
'Range of the number loop Number loop is the name of the variable
For numberloop = 1 To 80
'***NEW
SecondChart = 0
'Changes Cell D1 to value after equal sign
ActiveSheet.Range("A1") = numberloop
ActiveSheet.Calculate
'Stop now button Parameter
If StopNow Then Exit For
'***NEW
Sheets("Export HDA Forecast").Calculate
'ensures graph changes
Application.ScreenUpdating = True
DoEvents
DoEvents
'Put print chart code here single chart on active worksheet
'Copy the Chart
Chrt.CopyPicture _
Appearance:=xlPrinter, Format:=xlPicture
' Add a new slide
Set PPSlide = PPPres.Slides.Add(SldIndex, 12)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
'***NEW
PName = ActiveSheet.Range("a2").Value
Set myTextbox = PPSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=275, Top:=10, Width:=600, Height:=50)
With myTextbox.TextFrame.TextRange
.Text = PName
With .Font
.Size = 24
.Name = "Arial"
.Bold = True
End With
End With
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the chart picture
.Shapes.Paste.Select
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = 5
PPApp.ActiveWindow.Selection.ShapeRange.Top = 55
PPApp.ActiveWindow.Selection.ShapeRange.Height = 550
PPApp.ActiveWindow.Selection.ShapeRange.Width = 450
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
End With
'Brings back to the loop
Application.Wait (Now + TimeValue("0:00:01"))
SldIndex = SldIndex + 1
'***NEW
If SecondChart = 1 Then GoTo 200
SecondChart = 1
'Sheets("Export HDA Forecast").Select
Application.ScreenUpdating = True
DoEvents
DoEvents
'Put print chart code here single chart on active worksheet
'Copy the HDAChart
ChrtHDA.CopyPicture _
Appearance:=xlPrinter, Format:=xlPicture
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the chart picture
.Shapes.Paste.Select
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCFalse
PPApp.ActiveWindow.Selection.ShapeRange.Left = 0
PPApp.ActiveWindow.Selection.ShapeRange.Top = 302
PPApp.ActiveWindow.Selection.ShapeRange.Height = 240
PPApp.ActiveWindow.Selection.ShapeRange.Width = 961
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
'Create reference to Excel Range
Set ExcRng = Range("B10:F11")
'Copy Excel Range
ExcRng.Copy
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the Excel Range
.Shapes.Paste.Select
' Position pasted Excel Range
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCFalse
PPApp.ActiveWindow.Selection.ShapeRange.Left = 500
PPApp.ActiveWindow.Selection.ShapeRange.Top = 50
PPApp.ActiveWindow.Selection.ShapeRange.Height = 40
PPApp.ActiveWindow.Selection.ShapeRange.Width = 325
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
'Create reference to 2nd Excel Range
Set ExcRng = Range("B18:h21")
End With
'Copy Excel Range
ExcRng.Copy
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the Excel Range
.Shapes.Paste.Select
' Position pasted Excel Range
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCFalse
PPApp.ActiveWindow.Selection.ShapeRange.Left = 475
PPApp.ActiveWindow.Selection.ShapeRange.Top = 130
PPApp.ActiveWindow.Selection.ShapeRange.Height = 40
PPApp.ActiveWindow.Selection.ShapeRange.Width = 475
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
End With
End With
200 Next numberloop
End Sub
I have a Macro which loops through the master data in a workbook and exports all that graphs + tables associated with each of the numbers into PowerPoint. The issue with this is the loop has about 80 or so numbers in therefore left unchecked it can be running for a while.
I'm looking for a way to simply 'stop' the Macro running, e.g. by another button, instead of opening up the editor and pressing 'Stop' each time.
Anyone know an easy way to do this? Code is below:
Sub UK_Export_Sales_and_HDA_and_Forecast()
'Declare Powerpoint Object Variables
Dim PPTSlide As Object
'Animate Full
Dim i As Integer
'Declare Excel Object Variable
Dim Chrt As ChartObject
'Declare text box as shape
Dim objTextBox As Shape
'Declare Excel Cell Variables
Dim ExcRng As Range
' Reference existing instance of PowerPoint
Set PPApp = GetObject("", "Powerpoint.Application")
PPApp.Activate
On Error GoTo 10
15 Set PPPres = PPApp.ActivePresentation
slidecount = PPPres.Slides.Count
GoTo 20
10 PPApp.Presentations.Add
GoTo 15
20 SldIndex = 1
'Create reference to chart to export
Set Chrt = Sheets("Export Chart to PPT").ChartObjects(1)
'***NEW
Set ChrtHDA = Sheets("Export HDA Forecast").ChartObjects(1)
'Stop Now Parameter
StopNow = False
'Range of the number loop Number loop is the name of the variable
For numberloop = 1 To 80
'***NEW
SecondChart = 0
'Changes Cell D1 to value after equal sign
ActiveSheet.Range("A1") = numberloop
ActiveSheet.Calculate
'Stop now button Parameter
If StopNow Then Exit For
'***NEW
Sheets("Export HDA Forecast").Calculate
'ensures graph changes
Application.ScreenUpdating = True
DoEvents
DoEvents
'Put print chart code here single chart on active worksheet
'Copy the Chart
Chrt.CopyPicture _
Appearance:=xlPrinter, Format:=xlPicture
' Add a new slide
Set PPSlide = PPPres.Slides.Add(SldIndex, 12)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
'***NEW
PName = ActiveSheet.Range("a2").Value
Set myTextbox = PPSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=275, Top:=10, Width:=600, Height:=50)
With myTextbox.TextFrame.TextRange
.Text = PName
With .Font
.Size = 24
.Name = "Arial"
.Bold = True
End With
End With
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the chart picture
.Shapes.Paste.Select
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = 5
PPApp.ActiveWindow.Selection.ShapeRange.Top = 55
PPApp.ActiveWindow.Selection.ShapeRange.Height = 550
PPApp.ActiveWindow.Selection.ShapeRange.Width = 450
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
End With
'Brings back to the loop
Application.Wait (Now + TimeValue("0:00:01"))
SldIndex = SldIndex + 1
'***NEW
If SecondChart = 1 Then GoTo 200
SecondChart = 1
'Sheets("Export HDA Forecast").Select
Application.ScreenUpdating = True
DoEvents
DoEvents
'Put print chart code here single chart on active worksheet
'Copy the HDAChart
ChrtHDA.CopyPicture _
Appearance:=xlPrinter, Format:=xlPicture
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the chart picture
.Shapes.Paste.Select
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCFalse
PPApp.ActiveWindow.Selection.ShapeRange.Left = 0
PPApp.ActiveWindow.Selection.ShapeRange.Top = 302
PPApp.ActiveWindow.Selection.ShapeRange.Height = 240
PPApp.ActiveWindow.Selection.ShapeRange.Width = 961
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
'Create reference to Excel Range
Set ExcRng = Range("B10:F11")
'Copy Excel Range
ExcRng.Copy
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the Excel Range
.Shapes.Paste.Select
' Position pasted Excel Range
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCFalse
PPApp.ActiveWindow.Selection.ShapeRange.Left = 500
PPApp.ActiveWindow.Selection.ShapeRange.Top = 50
PPApp.ActiveWindow.Selection.ShapeRange.Height = 40
PPApp.ActiveWindow.Selection.ShapeRange.Width = 325
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
'Create reference to 2nd Excel Range
Set ExcRng = Range("B18:h21")
End With
'Copy Excel Range
ExcRng.Copy
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the Excel Range
.Shapes.Paste.Select
' Position pasted Excel Range
PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCFalse
PPApp.ActiveWindow.Selection.ShapeRange.Left = 475
PPApp.ActiveWindow.Selection.ShapeRange.Top = 130
PPApp.ActiveWindow.Selection.ShapeRange.Height = 40
PPApp.ActiveWindow.Selection.ShapeRange.Width = 475
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
End With
End With
200 Next numberloop
End Sub