How could I make this code run faster and smoother? - vba

Question

Three issues.
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.
Another issue I have is that I keep getting two different pop-ups:
"File now Available for Editing"
"User is currently editing workbook, would you like to run in read-only mode?"
Very annoying, but nothing I can't live with.
Lastly, I also sometimes get an error on this line:
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse But all I have to do is re-run the program and it'll go away.
I'm looking for any suggestions to make this code run a little faster and smoother, any recommendations are welcome.
Thanks!
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