O kadar fazla dosya varsa alttaki kodlu dosyayı deneyebilirsiniz hızı çalışması lazım.

Sub Getir()

    Dim cn As ADODB.Connection

    Dim rs As ADODB.Recordset

    Dim fso As New Scripting.FileSystemObject

    Dim file As file, yol As String, son As Long

    Dim bulunanSayfaAd As String, say As Long

    Const sayfa As String = "zarf"

    

    

    With ThisWorkbook.Sheets("Veri")

       .Range("B2" & Rows.Count).ClearContents

        Set cn = New ADODB.Connection

        

        ReDim arr(1 To Rows.Count - 1, 1 To 3)

        say = 0

        For Each file In fso.GetFolder(ThisWorkbook.Path).Files

            If fso.GetBaseName(ThisWorkbook.Name) <> fso.GetBaseName(file) And Left(file.Name, 2) <> "~$" And fso.GetExtensionName(file) Like "xls*" Then

                cn.ConnectionString = _

                "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";Extended Properties='Excel 12.0 Xml;HDR=NO;Imex=1';"

                cn.Open

                

                Set rs = cn.OpenSchema(adSchemaTables)

                Do Until rs.EOF

                    bulunanSayfaAd = rs.Fields("TABLE_NAME").Value

                    If Right(bulunanSayfaAd, 17) <> "$_xlnm#Print_Area" Then

                        If Mid(LCase(bulunanSayfaAd), 1, Len(LCase(bulunanSayfaAd)) - 1) = sayfa Then

                            yol = "'" & ThisWorkbook.Path & "\" & "[" & file.Name & "]" & sayfa & "'!R"

                            say = say + 1

                            arr(say, 1) = Application.ExecuteExcel4Macro(yol & 21 & "C" & 28) '21 satir,28 ise sütun

                            arr(say, 2) = Application.ExecuteExcel4Macro(yol & 7 & "C" & 31) '7 satir,31 ise sütun

                            arr(say, 3) = Application.ExecuteExcel4Macro(yol & 10 & "C" & 28) '10 satir,28 ise sütun

                        End If

                    End If

                    rs.MoveNext

                Loop

            End If

            If cn.State = 1 Then cn.Close

        Next

        If say > 0 Then .Range("B2").Resize(say, 3).Value = arr

    End With

     

    On Error Resume Next

    rs.Close: cn.Close: Set fso = Nothing: Set file = Nothing: Erase arr

End Sub