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"

   read-write

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

   read-only

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.

• Pinlop: pastebin.com/DSd4TdKA I fixed everything with your suggestions/ revised code. I nearly shed a tear when this worked so well. Thank you very much sir, it's down to 40 seconds and I can live with that! @Joffan
• Pinlop: oh, also for some reason I kept getting this error whenever it would go to paste onto the slide: imgur.com/x82sHh3. Really not sure what happened here but I did a work around with the On Error GoTo/Resume Next
• Joffan: Added some thoughts on the table pasting part.
• Pinlop: pastebin.com/dPkqg8KJ Fixed the code and made a change to hasIQs with this new logic. I only "learned" how to code a week and a half ago to write this, so obviously I'm not very experienced, but wow... I am amazed by how you can just do this with my code, and seemingly effortlessly fix a bunch of things with a few key strokes. Thank you @Joffan

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

• Pinlop: pastebin.com/DSd4TdKA Here is my revised code with suggestion from Joffan and yourself. Thank yo uvery much @joseph4tw I appreciate the tips! Only one I didn't pull through is the Sub comments. I'm not sure what the advantages would be, and I'm also not sure how I would implement them. Could you explain further?