Извлечение значений ячеек из нескольких файлов Excel замедляет работу ноутбука

Question

Я скопировал и изменил следующий код, чтобы извлечь различные значения ячеек из множества файлов .xlsx в одной папке и вставить их в таблицу в новом файле.По крайней мере с screenupdating = false экран не мерцает, но моя проблема в том, что этот код работает очень медленно.Для 200 файлов заполнение новой таблицы занимает 2 минуты, и я вижу, что указатель поворачивается.

Код работает нормально, но возможно ли сделать этот код более тонким или быстрым?

Спасибо

 Sub CopyExternData()

 Dim StatusCalc

      'Makrobremsen lösen - Am beginn eine sMakros
      With Application
.EnableEvents = False
StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
.Calculation = xlCalculationManual
.ScreenUpdating = False
      End With

Const sXlsPath = "C:\Users\admin\Desktop\Test\"
Const iStartZeile = 4
Const iStartSpalte = 1
Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29"

Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As Worksheet
Dim aCells As Variant, iNextLine As Long, i As Integer

Set oWks0 = ThisWorkbook.ActiveSheet

aCells = Split(Zellen, ","):  iNextLine = iStartZeile

Set oFso = CreateObject("Scripting.FilesystemObject")

ActiveSheet.Range("A4:I1000").ClearContents

For Each oFile In oFso.GetFolder(sXlsPath).Files
    If LCase(oFso.GetExtensionName(oFile.Name)) = "xlsx" Then
        If ThisWorkbook.Path <> oFile.Name Then
            Set oWkb1 = Workbooks.Open(oFile.Path)
            Set oWks1 = oWkb1.Sheets(1)
            For i = 0 To UBound(aCells)
                oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells(i))).Value
            Next
            oWkb1.Close False
            iNextLine = iNextLine + 1
        End If
    End If
Next

    Beenden: 'Sprungadresse zum Beenden diese Makros - nicht mit Exit Sub arbeiten!!
    'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
      With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
      End With

 End Sub