Find text in PowerPoint, match to text in Excel, copy columns with matching text as a table and paste back into PowerPoint

Question

This code is running in 4-5 minutes for me with the database that I currently have. Normally it will be a database with 100~ columns. I want to make this faster.

The second issue I have is that I keep getting two different pop-ups:

1. "File now Available for Editing"

   

2. "User is currently editing workbook, would you like to run in read-only mode?"

   

Very annoying, but nothing I can't live with.

I'm looking for any suggestions to make this code run a little faster and smoother, any recommendations are welcome.

Public Sub averageScoreRelay()
    ' 1. Run from PPT and open an Excel file
    ' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
    ' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
    ' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
    ' 4. Copy table from xl Paste Table into ppt
    ' 5. Do this for every slide

 
 
'Timer start
    Dim StartTime As Double
    Dim SecondsElapsed As Double
        StartTime = Timer   
        
'Create variables    
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim pptSlide As Slide
    Dim Shpe As Shape
    Dim pptText As String
    Dim pptPres As Object
    Dim iq_Array As Variant
    Dim arrayLoop As Integer
    Dim i As Integer
    Dim myShape As Object
    Dim colNumb As Integer
    Dim size As Integer
    Dim k As Integer
    Dim lRows As Long
    Dim lCols As Long

    ' Create new excel instance and open relevant workbook
    Set xlApp = New Excel.Application
    'xlApp.Visible = True 'Make Excel visible
    Set xlWB = xlApp.Workbooks.Open("file.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
    If xlWB Is Nothing Then ' may not need this if statement. check later.
        MsgBox ("Error retrieving Average Score Report, Check file path")
        Exit Sub
    End If
    
    xlApp.DisplayAlerts = False
    
    With xlWB.Worksheets("Sheet1")
        colNumb = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With

    'Create a new blank Sheet in excel, should be "Sheet2"

    xlWB.Worksheets.Add After:=xlWB.ActiveSheet

    'Make pptPres the ppt active
    Set pptPres = PowerPoint.ActivePresentation

    'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
    For Each pptSlide In pptPres.Slides
        pptSlide.Select
        
        'searches through shapes in the slide
        For Each Shpe In pptSlide.Shapes
        
            k = 1
            
            'Identify if there is text frame
            If Shpe.HasTextFrame Then
            
                'Identify if there's text in text frame
                If Shpe.TextFrame.HasText Then
                
                    'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
                    pptText = Shpe.TextFrame.TextRange
                    pptText = LCase(Replace(pptText, " ", vbNullString))
                    pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)

                    
                    'Identify if within text there is "iq_"
                    If InStr(1, pptText, "iq_") > 0 Then
                    
                        'set iq_Array as an array of the split iq's
                        iq_Array = Split(pptText, ",")
                        
                        'Find size of the array
                        size = UBound(iq_Array) - LBound(iq_Array)
                        
                        'loop for each iq_ in the array'
                        For arrayLoop = 0 To size
                        
                        'Statement that will take iq_'s in the form "iq_9" or "iq_99" or "iq_999"
                        If iq_Array(arrayLoop) Like "iq_#" Or iq_Array(arrayLoop) Like "iq_##" Or iq_Array(arrayLoop) Like "iq_###" Then
                        
                            'loops for checking each column
                            For i = 1 To colNumb
                            
                                'Copies the first column (role column) for every slide that needs it
                                If i = 1 And arrayLoop = 0 Then
                                
                                    'copy column
                                    xlWB.Worksheets("Sheet1").Columns(1).Copy
                                    
                                    'paste column in Sheet2 which was newly created
                                    xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
                                    
                                'If this is not the role column, then check to see if the iq_'s match from ppt to xl
                                ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = iq_Array(arrayLoop) And i <> 1 Then
                                    
                                    'Serves to paste in the next column of Sheet2 so that we end up with a table
                                    k = k + 1
                                    
                                    'same as above
                                    xlWB.Worksheets("Sheet1").Columns(i).Copy
                                    xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
                                    
                                    'Go to next array
                                    GoTo Line2
                                End If
                            Next i
                            
                        'Same as above, just this one is for iq_'s with form "iq_45,46,47" instead of "iq_45,iq_46,iq_47"
                        ElseIf (iq_Array(0) Like "iq_#" Or iq_Array(0) Like "iq_##" Or iq_Array(0) Like "iq_###") And (IsNumeric(iq_Array(arrayLoop)) And Len(iq_Array(arrayLoop)) <= 3) Then
                            For i = 1 To colNumb
                                If i = 1 And arrayLoop = 0 Then
                                    xlWB.Worksheets("Sheet1").Columns(1).Copy
                                    xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
                                ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = ("iq_" & iq_Array(arrayLoop)) And i <> 1 Then 'if iq in ppt = iq in xl and if not the first cell then execute
                                    k = k + 1
                                    xlWB.Worksheets("Sheet1").Columns(i).Copy
                                    xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
                                    GoTo Line2
                                End If
                            Next i
                        End If
                        
Line2:

                        Next arrayLoop
                    End If
                End If
            End If
        Next Shpe
        
    'calculate last row and last column on sheet2. aka. find Table size
    With xlWB.Worksheets("Sheet2")
        lRows = .Cells(.Rows.Count, 1).End(xlUp).Row
        lCols = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        'If only one column then go to next slide
        If lRows = .Cells(1, 1).End(xlUp).Row And lCols = .Cells(1, 1).End(xlToLeft).Column Then
            GoTo Line1
        End If
        
            'Copy table
            .Range(.Cells(1, 1), .Cells(lRows, lCols)).Copy
    End With
    
            'Paste Table into ppt
            pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse
            
            'Recently pasted shape is the last shape on slide, so it will be the same as count of shapes on slide
            Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
            
            'Set position:
            myShape.Left = -200
            myShape.Top = 200
            
            'Clear Sheet2 for next slide
            xlWB.Worksheets("Sheet2").Range("A1:P10").Clear
            
Line1:

    Next pptSlide

    xlWB.Worksheets("Sheet2").Delete
    xlWB.Close
    xlApp.Quit
    
    xlApp.DisplayAlerts = True
    
    'End Timer
    SecondsElapsed = Round(Timer - StartTime, 2)
        MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

Answer 1

I recommend setting up objects for the Excel worksheets:

Dim ShRef As Excel.Worksheet
Dim ShWork As Excel.Worksheet

Set ShRef = xlWB.Worksheets("Sheet1")
'Create a new temporary worksheet in excel
Set ShWork = xlWB.Worksheets.Add(After:=xlWB.ActiveSheet)

A lot of your time is probably spent look at Excel and doing copy/paste stuff.

The referencing can certainly be quicker; you just need to collect the iq_999 numbers and corresponding columns into a local reference. This can be as simple as an array that you review each time, which is still far quicker than checking across into an Excel cell.

Dim IQRef() As String
Dim iCol As Long
' get number of IQ references
colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
ReDim IQRef(colNumb)
' capture IQ refs locally
For iCol = 2 To colNumb
    IQRef(iCol) = ShRef.Cells(1, iCol).Value
Next iCol

and then for your main table-building, you only need to check the first element once to decide if subsequent numbers :

                    'set iq_Array as an array of the split iq's
                    iq_Array = Split(pptText, ",")

                    Dim HasIQs As Boolean
                    Dim CheckStr As String
                    Dim pCol As Long
                    HasIQs = iq_Array(0) Like "iq_#" Or iq_Array(0) Like "iq_##" Or iq_Array(0) Like "iq_###"
                    If HasIQs Then
                        ' paste inital column into temporary worksheet
                        ShRef.Columns(1).Copy Destination:=ShWork.Columns(1)
                    End If

                    ' loop for each iq_ in the array
                    For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
                        ' Take copy of potential ref and adjust to standard if required
                        CheckStr = iq_Array(arrayLoop)
                        If HasIQs And Left(CheckStr, 3) <> "iq_" Then CheckStr = "iq_" & CheckStr

                        ' Look for existence of corresponding column in local copy array
                        pCol = 0
                        For iCol = 2 To colNumb
                            If CheckStr = IQRef(iCol) Then
                                pCol = iCol
                                Exit For
                            End If
                        Next iCol

                        If pCol > 0 Then
                            ' Paste the corresponding column into the forming table
                            k = k + 1
                            ShRef.Columns(pCol).Copy Destination:=ShWork.Columns(k)
                        End If

                    Next arrayLoop

One possible bug is that you reset k your output column to 1 with each Shape but you only output for each Slide. If there is more than one Shape with relevant information you will lose some or all of the first Shape's input in your table.

---

Edit to add: Your pasting decision could just be based on the value of k (which might better be called something like outCol) and the remaining table-making code simplified as follows:

        If k > 1 Then 'data was added
            ' Copy table
            ShWork.UsedRange.Copy ' all the data added to ShWork

            Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
            'Set position:
            myShape.Left = -200
            myShape.Top = 150 + i
            i = i + 150

            ' Clear data from temporary sheet
            ShWork.UsedRange.Clear
        End If

nextShpe: '...

You might still need to add your error checking back in; I can't tell what is causing that.

Answer 2

I'm not entirely sure of your first two issues, but I have some suggestions for your Sub routine.

1. This Sub has too many responsibilities. You should break it up into other private Sub routines and private functions. A simple rule-of-thumb is that whenever you have a loop or a big If statement, chances are you can break that out into its own Sub / Function.
2. Declare variables where you need them. Doing this makes the variable more relevant where it's actually used.
3. Reduce the amount of nesting. 9 Layers of nesting is 7 layers too many.
4. Make your labels more meaningful. If you need to skip the logic in your For loops, then I would recommend something like NextArrayLoop: instead of Line2:

pptSlide.Select is probably unnecessary, but that's just a guess.

Here is some revised code, with comments describing what I changed:

    For Each pptSlide In pptPres.Slides
        For Each Shpe In pptSlide.Shapes
            ' k = 1 ' what does k do, again? probably want to rename this. On second thought, scratch this. You only need this for pasting stuff. Declare it later when you need it.

            If Not Shpe.HasTextFrame Then GoTo NextPptSlide 'boom, one less nested If statement
            If Not Shpe.TextFrame.HasText Then GoTo NextShpe ' boom, another nested If statement bites the dust

            Dim pptText As String ' declare variables where you need them
            pptText = GetPptText(Shpe.TextFrame.TextRange) ' use a private function

            If InStr(1, pptText, "iq_") <= 0 Then GoTo NextShpe ' again, another nested if gone

            Call ProcessIqText(pptText, xlWb) ' leave the responsibility of this work to another Sub

            ' ... etc.
NextShpe:
        Next Shpe
NextPptSlide:
    Next pptSlide