< Jetzt funktioniert es! Dauert aber 40 min bis es alles geladen hat.

Guten Morgen :D

hättest ja gleich x 100 Files schreiben  können, egal - eine Kanne Kaffee mehr ;)

Anbei Muster für schlappe 5 sec

Gruß & Tschüss

Option Explicit

Sub Werteholen()
'privat nur Test
'Dim obTimer As New CHighResTimer  'Test - Zeitmessung
'
Dim obj_fso As Object
Set obj_fso = CreateObject("Scripting.FileSystemObject")
'
'
Dim rngPfadDatei As Range, rngFcnt As Range
'
  'Zeile 1 Überschrift A= voller Dateipfad !, B = Zustand, C:Q = Zahlen 1 - 15, R = Datenfeld
  Set rngPfadDatei = ActiveWorkbook.Sheets("Tabelle1").Range("A2:A101")
  ActiveWorkbook.Sheets("Tabelle1").Range("B2:R101").Clear
  '
  'obTimer.StartTimer  'Test - Zeitmessung starten
  For Each rngFcnt In rngPfadDatei
    If obj_fso.fileExists(rngFcnt.Formula) Then
      rngFcnt.Offset(0, 1).Formula = "OK"
      '
      'Nur ein Datenfeld holen !!!  - Datei , Bereichsangabe exakt, Ziel
      'add Ziel - hattu nur Daten im Range, dann False und Ziel + 1 Zeile
      If NurEinDatenfeld(rngFcnt.Formula, "[Tabelle4$B3:B300]", "R3", False) Then
      End If
      '
      MeineAuswertung rngFcnt, "R2" 'Datenfeldbeginn
      '
    Else
      rngFcnt.Offset(0, 1).Formula = "NA"
    End If
  Next rngFcnt
  
  Columns("R:R").Clear  'letztes Datenfeld
  '
  'obTimer.StopTimer 'Test - Zeitmessung beenden, ausgeben
  'Debug.Print "100 Dateien x 15 Vergleiche " & WorksheetFunction.Round(obTimer.Elapsed, 4) & " Sekunden"
  'das waren schlappe 5 Sekunden
Set obj_fso = Nothing
'privat nur Test
Set obTimer = Nothing
End Sub

Private Sub MeineAuswertung(ByVal MeineDatei As Range, _
  strDatenfeld As String)
Dim rngDatenfeld As Range, rngcnt As Range
Dim SucheWert As Double
'
On Error GoTo errorhandler
  Set MeineDatei = MeineDatei.End(xlToRight).Offset(0, 1) 'erste leere
  Set rngDatenfeld = Range(strDatenfeld)
  Set rngDatenfeld = Range(rngDatenfeld, rngDatenfeld.End(xlDown)) 'Datenfeld bestimmen
  '
  Do While MeineDatei.Column < rngDatenfeld.Column
    SucheWert = Cells(1, MeineDatei.Column)
    MeineDatei.Value = WorksheetFunction.CountIf(rngDatenfeld, SucheWert)
    Set MeineDatei = MeineDatei.Offset(0, 1)
  Loop
On Error GoTo 0
Exit Sub
errorhandler:
MsgBox "Fehler in Auswertung " & MeineDatei.Address, vbCritical
On Error GoTo 0
End Sub


Private Function NurEinDatenfeld(ByVal strPfadDatei As String, _
  ByVal strDatenBereich, ByVal strZieladresse, _
  ByVal Kopf As Boolean) As Boolean
Dim oDatenfeld As Object
Dim strVerbindung As String
Dim strSQL As String

'Achtung Microsoft.ACE.OLEDB.12.0 einbinden
strVerbindung = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strPfadDatei & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""

strSQL = "SELECT * FROM " & strDatenBereich

On Error GoTo errorhandler
Set oDatenfeld = CreateObject("ADODB.Recordset")
'
oDatenfeld.Open strSQL, strVerbindung, 0, 1, 1
'
If Not oDatenfeld.EOF Then
  ActiveSheet.Range(strZieladresse).CopyFromRecordset oDatenfeld
  If Not Kopf Then Range(strZieladresse).Offset(-1, 0).Value = _
    oDatenfeld.Fields(0).Name
  NurEinDatenfeld = True  'erfolgreich
Else
MsgBox "keine Daten in " & strPfadDatei, vbCritical
End If
errorhandler:
oDatenfeld.Close
Set oDatenfeld = Nothing
On Error GoTo 0
End Function