Speed up Macro

Hi all

I have this macro which searches through dozens of spreadsheets based on a specified list, here is the code:

Basically I am looking at ways to speed up the the running of the macro as it takes about 15 minutes to go through about 50 spreadsheets. Attached is the report runner spreadsheet this macro is contained in (Unsold Tickets button in 'Unsold Ticket Report'). Also attached is a sample spreadsheet where the data is pulled from (Judas Priest) and the template where the information is output on (Unsold Tickets). Thank you in advance!

Option Explicit

Sub Tickets_Unsold()
Dim inFiles() As Variant
Dim InData() As Variant
Dim inRng As Range

Dim ws1 As Worksheet, ws2 As Worksheet
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim srow As Long, lrow As Long
Dim lastrow1 As Long, Lastrow As Long
Dim lastcol As Long
Dim r As Long, rr As Long, row As Long
Dim wsname As String, wbname As String
Dim FilePath As String
Dim FindString As String
Dim var As Variant

ThisWorkbook.Activate

Set wb1 = ThisWorkbook

FilePath = Range("C1")

wbname = "Unsold Tickets.xlsx"
'
' Open the "Unsold Tickets" file if not open
'
If Not WorkbookIsOpen(wbname) Then
    Workbooks.Open Filename:= _
    FilePath & wbname
End If

Set wb2 = Workbooks(wbname)
rr = 2

wb1.Activate

With wb1
'
'  Find last row in Column A
'
    lastrow1 = Cells(Rows.Count, 1).End(xlUp).row
    
    Set inRng = Range(Cells(3, 1), Cells(lastrow1, 1))
    '
    '  Assign data to in-core array (speedier processing)
    '
    inFiles = inRng
    '
    '  Loop through all the files
    '
    For r = 1 To UBound(inFiles, 1)
    
        wbname = inFiles(r, 1)
        '
        ' Open workbook
        '
        If Not WorkbookIsOpen(wbname) Then
            Workbooks.Open Filename:= _
            FilePath & wbname
        End If
        
        Set wb3 = Workbooks(wbname)
        
        wb3.Activate
        
        With wb3
        
            FindString = "Total Purchased"
            var = Application.Match(FindString, Range("B1:B1000"), 0)
            
            If IsError(var) Then
               MsgBox "End of table (""Total Purchased"") not found: exit program"
               Exit Sub
            End If
            
            Lastrow = var
            lastcol = Cells(7, Columns.Count).End(xlToLeft).Column
            
            Set inRng = Range(Cells(1, 2), Cells(Lastrow, lastcol))
    '
    '  Assign data to in-core array (speedier processing)
    '
             InData = inRng
            
             For row = 8 To UBound(InData, 1)
             '
             ' find unsold seats
             '
                If IsNumeric(InData(row, 12)) And InData(row, 12) > 0 Then
                                               
                    wb2.Sheets("Sheet1").Cells(rr, 4) = InData(row, 1)
                    wb2.Sheets("Sheet1").Cells(rr, 6) = InData(row, 3)
                    wb2.Sheets("Sheet1").Cells(rr, 7) = InData(row, 4)
                    wb2.Sheets("Sheet1").Cells(rr, 8) = InData(row, 5)
                    wb2.Sheets("Sheet1").Cells(rr, 9) = InData(row, 10)
                    wb2.Sheets("Sheet1").Cells(rr, 11) = InData(row, 12)
                    wb2.Sheets("Sheet1").Cells(rr, 12) = InData(row, 13)
                    wb2.Sheets("Sheet1").Cells(rr, 13) = InData(row, 14)
                    wb2.Sheets("Sheet1").Cells(rr, 14) = InData(row, 18)
                    wb2.Sheets("Sheet1").Cells(rr, 1) = InData(1, 1)
                    wb2.Sheets("Sheet1").Cells(rr, 2) = InData(2, 1)
                    wb2.Sheets("Sheet1").Cells(rr, 3) = Trim(Mid(InData(3, 1), InStr(1, InData(3, 1), ",") + 1, 50))
                    rr = rr + 1
                               
                End If
                
            Next row
        
        End With
        
        Workbooks(wbname).Close SaveChanges:=False
        
     rr = rr + 1
     
     wb1.Activate
     
     Next r
         
 End With

wb2.Activate


   
End Sub
Private Function WorkbookIsOpen(wbname) As Boolean
'   Returns TRUE if the workbook is open
    Dim x As Workbook
    On Error Resume Next
    Set x = Workbooks(wbname)
    If Err = 0 Then WorkbookIsOpen = True _
        Else WorkbookIsOpen = False
End Function