How do I return focus to Excel after copy to Powerpoint?

[Johnny C]

I've written some code to copy charts and ranges to Powerpoint. Powerpoint can't be saved and closed at the end.

How do I get focus back to Excel after the final paste? here's the code. I've tried a few things at the end.

'First we declare the variables we will be using
Dim ppApp As PowerPoint.Application
Dim xlApp As Excel.Application
Dim ppSelected As PowerPoint.Presentation
Dim activeSlide As PowerPoint.Slide
Dim sht As Worksheet
Dim cht As ChartObject
Dim strSheetName$, strThisSheet$, ppSelectedName$, strControlSheet$, strChartName$, strRangeName$, strSheetEnd$
Dim strRefersto$, strRangeStem$, strTemplate$, strCopyType$
Dim intRowCount&, intLastRow&, intPPCount&, intDocNum&, intErrorCount&
Dim intCount&, intSheetEnd&, intExtSheet&, intNumItems&
Dim boolCopycharts As Boolean, boolRangeCopy As Boolean, boolRangeother As Boolean, boolCopyRange As Boolean
Dim shp As PowerPoint.Shape, intShpWidth%, dblShpRatio#
Dim ppActiveShape As PowerPoint.Shape
Dim nm As Name
    
    Application.ScreenUpdating = False
    
    strThisSheet = ActiveSheet.Name

    'Get the selected powerpoint presentation selected
    ppSelectedName = frmCopyWBControl.cmbOpenDocs.Value
    If ppSelectedName = "" Then
        MsgBox "You need to select a PowerPoint Presentation to copy to"
        Exit Sub
    End If
    'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    
    strControlSheet = GetWks("wksCopyControl")
    If strControlSheet = "" Then Exit Sub 'Something went wrong, sheet wsa deleted?
    Sheets(strControlSheet).Activate
    
    intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    intErrorCount = 0
            
            
' Now loop through selected items on Listbox and get data items. then copy to PP.
    intNumItems = frmCopyWBControl.lstCopyControl.ListCount
    For intRowCount = 0 To intNumItems - 1
        If frmCopyWBControl.lstCopyControl.Selected(intRowCount) Then
            strCopyType = frmCopyWBControl.lstCopyControl.List(intRowCount, 0)
            strSheetName = frmCopyWBControl.lstCopyControl.List(intRowCount, 1)
            strRangeName = frmCopyWBControl.lstCopyControl.List(intRowCount, 1)
            strChartName = frmCopyWBControl.lstCopyControl.List(intRowCount, 2)
            strRefersto = frmCopyWBControl.lstCopyControl.List(intRowCount, 2)
            intDocNum = frmCopyWBControl.lstCopyControl.List(intRowCount, 3)
            
' Check PP is up and running - it should be the macro wouldn't run if it wasn't BUT PP can crash due to
' Excel and PP getting out of sync. The macro tries to cope with it but you never know...
            DoEvents
            On Error Resume Next
            Set ppApp = GetObject(, "PowerPoint.Application")
            On Error GoTo 0
            If Err.Number <> 0 Then
                MsgBox "Powerpoint seems to have been closed down"
                Exit Sub
            End If
            
' Now loop through presentations until wefind the one selected on the userform.
            DoEvents
            For intPPCount = 1 To ppApp.Presentations.Count
                If ppApp.Presentations.Item(intPPCount).Name = ppSelectedName Then Set ppSelected = ppApp.Presentations.Item(intPPCount)
            Next intPPCount
            DoEvents
            ppApp.ActiveWindow.ViewType = ppViewSlide
            On Error Resume Next

' Select the slide from the userform PP slide value
            Set activeSlide = ppSelected.Slides(intDocNum)
            If Err.Number <> 0 Then
                MsgBox "Error - there is no slide " & intDocNum & " on the " & ppSelectedName & " presentation"
                intErrorCount = intErrorCount + 1
            Else
                DoEvents
                
' Now check what type of copy was selected and deal with each accordingly.
' Copy range is the same as Specified range
                Select Case strCopyType
                    Case Is = "Chart"
                        Sheets(strSheetName).Activate
                        ActiveSheet.ChartObjects(strChartName).Select
                        ActiveChart.ChartArea.Copy
                        
                        ' When you paste a table, excel and PP get out of sync. This loop lets them catch up with each other.
                        For intCount = 1 To 500: DoEvents: Next
                        activeSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
                        activeSlide.Shapes(activeSlide.Shapes.Count).Fill.BackColor.RGB = RGB(255, 255, 255)
                        For intCount = 1 To 500: DoEvents: Next
                        
                        DoEvents
                        Sheets(strSheetName).Activate
                    Case Is = "Copy range", Is = "Specified range"
                        intSheetEnd = InStr(strRefersto, "!")
                        intExtSheet = InStr(strRefersto, "]")
                        If intSheetEnd <> 0 And intExtSheet = 0 Then   ' This excludes ranges that refer to other ranges and external objects
                            strSheetName = Left(strChartName, intSheetEnd - 1)
                            Sheets(strSheetName).Activate
                            Range(strRangeName).Copy
                            
                            ' When you paste a table, excel and PP get out of sync. This loop lets them catch up with each other.
                            For intCount = 1 To 5000: DoEvents: Next
                            activeSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
                            activeSlide.Shapes(activeSlide.Shapes.Count).Fill.BackColor.RGB = RGB(255, 255, 255)
                            For intCount = 1 To 5000: DoEvents: Next
                            
                            Sheets(strSheetName).Activate
                            DoEvents
                        End If
                    Case Else
                            ' put something here if needed - currently it's not
                End Select
            End If
        End If
    Next intRowCount
    
    ActiveWorkbook.Sheets(strThisSheet).Activate
' Clear objects out of memory
    Set ppApp = Nothing
    Set ppSelected = Nothing
    Set activeSlide = Nothing
    DoEvents
    For intCount = 1 To 50: DoEvents: Next
    Application.ScreenUpdating = True
    xlApp.AppWinStyle.MaximizedFocus
    AppActivate Title:=Application.ActiveWindow.Caption
    ActiveWorkbook.Sheets(strThisSheet).Activate
    AppActivate Application.Caption
    Application.CutCopyMode = False
    Cells(1, 1).Select
End Sub

 

[Johnny C]

Solved...

it needed this in the macro that opened the Userform.

    AppActivate ("Microsoft Excel")
    Application.ScreenUpdating = True
    AppActivate Title:=Application.ActiveWindow.Caption
    AppActivate Application.Caption