Consulting

Results 1 to 2 of 2

Thread: Button to Stop Number Loop Code Running

  1. #1

    Button to Stop Number Loop Code Running

    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
    Last edited by Aussiebear; 11-15-2021 at 05:42 AM. Reason: Added code tags to supplied code

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Demonstration in the attached.
    Need to keep at least one DoEvents within the loop.
    Global variable StopNow
    Loop only updates cell E1.
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •