suchen in ordnern + rauskopieren

      
Option Explicit
Sub SeekSerialNumbers()
Dim fs As FileSearch
Dim rng As Range, Bereich As Range
Dim actSheet As Worksheet, newSheet As Worksheet
Dim sPath As String, strForm As String, strForm2 As String, _
                        strfile As String, strName As String
Dim lFile As Long, lRow As Long
Set actSheet = ThisWorkbook.Sheets("Tabelle1")
Set Bereich = actSheet.Range("A1:A1453")
Set newSheet = ThisWorkbook.Worksheets.Add(after:=actSheet)
newSheet.Name = "Neu"
Set fs = Application.FileSearch
On Error GoTo ERRORHANDLER
Application.ScreenUpdating = False
sPath = "D:\Temp\SN" 'Pfad zum Ordner mit den Seriennummern - anpassen

   With fs
   .NewSearch
   .LookIn = sPath
   .SearchSubFolders = False
   .FileType = msoFileTypeExcelWorkbooks
   .Execute
   
      For lFile = 1 To .FoundFiles.Count
      
      strName = Right(.FoundFiles(lFile), InStr(1, StrReverse(.FoundFiles(lFile)), "\") - 1)
      strfile = "'" & sPath & "\[" & strName & "]Monitor'!$B:$B,0)"
      
         For Each rng In Bereich
         
         strForm = "=MATCH(" & actSheet.Name & "!" & rng.Address & "," & strfile
         strForm2 = "='" & sPath & "\[" & strName & "]Übersicht'!$B3"
         
         newSheet.Cells(65536, 1).Formula = strForm
         
            If IsNumeric(newSheet.Cells(65536, 1)) Then
            lRow = lRow + 1
            newSheet.Cells(lRow, 1) = rng.Value
            newSheet.Cells(lRow, 2) = strForm2
            newSheet.Cells(lRow, 2) = newSheet.Cells(lRow, 2).Value
            Exit For
            End If
         
         Next
      
      Next
   
   End With
   
ERRORHANDLER
Application.ScreenUpdating = True
   
newSheet.Cells(65536, 1).ClearContents
End Sub 

ERRORHANDLER:
Application.ScreenUpdating = True

      
Option Explicit
Sub SucheInGeschlossenenDateienMitFSO()
'by - j.ehrensberger
'Die Suchbegriffe (Tabelle1 - A1:A1453) werden in allen
'Exceldateien (Tabelle "Monitor") eines Verzeichnisses gesucht (mittels Formel)!
'Bei positivem Formelergebnis wird aus einem anderen Blatt (Übersicht)
'der Datei, ein Wert ausgelesen und mit dem Suchbegriff
'in ein neues Tabellenblatt geschrieben.
'Die Dateinamen werden mit Hilfe des "FileSystemObject" ausgelesen

Dim fso, fo, fF, foF
Dim Bereich As Variant
Dim actSheet As Worksheet, newSheet As Worksheet
Dim sPath As String, strForm As String, strForm2 As String, strfile As String
Dim lRow As Long, n As Integer, i As Integer
On Error GoTo ERRORHANDLER
Application.ScreenUpdating = False
Set actSheet = ThisWorkbook.Sheets("Tabelle1")
Bereich = actSheet.Range("A1:A1453").Value
Set newSheet = ThisWorkbook.Worksheets.Add(after:=actSheet)
newSheet.Name = "Neu"
sPath = "D:\Temp\SN" 'Pfad zum Ordner mit den Seriennummern - anpassen

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fo = fso.GetFolder(sPath)
   Set foF = fo.Files
   
      For Each fF In foF
      i = i + 1
         If fso.GetExtensionName(fF) = "xls" Then
         
         Application.StatusBar = "Durchsuche Datei: """ & fF.Name & _
         """ ( " & i & " von " & foF.Count & " ) ; Insgesamt gefunden: " & lRow
         
         strfile = "'" & sPath & "[" & fF.Name & "]Monitor'!$B:$B,0)"
         
            For n = 1 To UBound(Bereich, 1)
            If Bereich(n, 1) <> "" Then
            strForm = "=MATCH(""" & Bereich(n, 1) & """," & strfile
            strForm2 = "='" & sPath & "[" & fF.Name & "]Übersicht'!$B3"
            
            newSheet.Cells(65536, 1).Formula = strForm
            
               If IsNumeric(newSheet.Cells(65536, 1)) Then
               lRow = lRow + 1
               newSheet.Cells(lRow, 1) = Bereich(n, 1)
               newSheet.Cells(lRow, 2) = strForm2
               newSheet.Cells(lRow, 2) = newSheet.Cells(lRow, 2).Value
               Bereich(n, 1) = ""
               
         Application.StatusBar = "Durchsuche Datei: """ & fF.Name & _
         """ ( " & i & " von " & foF.Count & " ) ; Insgesamt gefunden: " & lRow
         
               End If
            End If
            Next
            
         End If
   
      Next
   
ERRORHANDLER:
   If Err.Number = 1004 Then
      Err.Clear
      Resume Next
   ElseIf Err.Number <> 0 Then
      MsgBox Err.Description, vbCritical, "Fehler"
      Resume ERROREXIT
   End If
MsgBox "Suche abgeschlossen!"
ERROREXIT:
Set fso = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
On Error Resume Next
newSheet.Cells(65536, 1).ClearContents
End Sub