Help optimizing this code

Hello,

This code opens a new workbook, loops throughout all excel workbooks in a folder, opens the first one, loops throughout the cells of the table of the first worksheet and if the conditional formatting color is the desired, copies the cell value from the first column which is an ID to the new workbook.

It's basically so I can know what IDs are still undone in all the files.

It works but as more files are added to the folder, the slower it gets (at the beginning I call another subprocedure to turn things off like events, screen updating and so on which I ommited here). It's still faster than checking manually each file but maybe it can be optimized somehow. I thought of trying with an array but don't know exactly how I could do it.

Sub importPendingCases()

Dim newWbk As Workbook
Set newWbk = Workbooks.Add

Dim newWks As Worksheet
Set newWks = newWbk.Sheets(1)

Dim MyFiles As String

MyFiles = Dir("FolderPath*.xlsx.lnk")

Do While MyFiles <> ""
    
    Dim wbk As Workbook
    Set wbk = Workbooks.Open("FolderPath" & MyFiles, False, False)
    wbk.Activate
    
    Dim wks As Worksheet
    Set wks = wbk.Sheets(1)

    Dim tbl As ListObject
    Set tbl = wks.ListObjects("Table1")
    
    Dim rng As Range
    Set rng = tbl.DataBodyRange
    
    With rng
    
        Dim tRows As Long
        tRows = .Rows.Count
    
    End With
    
    Dim r As Long
                
    For r = 1 To tRows
    
        Dim c As Range
        
        For Each c In rng.Cells(r, 1)
        
            If c.DisplayFormat.Interior.Color = 45559 Then
                
                Dim lastRow As Long
                
                lastRow = newWks.Cells(Rows.Count, 1).End(xlUp).Row
                
                newWks.Range("A" & lastRow + 1).Value = wks.Range("A" & r + 1).Value
            
            End If
            
         Next c
    
    Next r

    wbk.Close False

    MyFiles = Dir
    
Loop

End Sub