suchen in ordnern + rauskopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Taz!
Hab jetzt keine Zeit zum ausführlichen Testen!
Probier mal diesen Code.

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

Gruß Sepp
P.S.: Rückmeldung nicht vergessen!

Hallo Taz!
Da hab ich dich falsch verstanden!
Ich hab den Code jetzt umgestellt, so das immer alle Nummern in allen
Dateien gesucht werden!
Wird aber natürlich noch länger dauern, es sind immerhin über 630.000
Vergleiche die gemacht werden müssen.
Um das ganze ein wenig zu beschleunigen lese ich jetzt den Bereich mit den
Seriennummern in Tabelle1 in ein Array ein. Weiters werden die Files nicht
mehr per FileSearch ermittelt, sondern mttels "FileSystemObject".
Und um das ganze noch ein wenig schneller zu machen, werden gefundene Seriennummern
aus dem Array entfernt, weil sie ja sowieso nicht mehr gefunden werden!
Um wenigstens zu wissen, das der Code arbeitet, wird in der Statuszeile
eine Info über den bisherigen Verlauf der Suche angezeigt!
Hier der Code.

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

Viel Spass und Geduld;-))
Gruß Sepp
P.S.: Rückmeldung nicht vergessen!

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

suchen in ordnern + rauskopieren

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread