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

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

With xlWB.Worksheets("Sheet1")
colNumb = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

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

'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

'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

'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub


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


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 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.

• 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 Sep 19 '17 at 17:43
• 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 – Pinlop Sep 19 '17 at 17:48
• Added some thoughts on the table pasting part. – Joffan Sep 19 '17 at 19:52
• 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 – Pinlop Sep 19 '17 at 20:33

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

• 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? – Pinlop Sep 19 '17 at 17:45