Hallo,
bei mir funktioniert die Suche mit der angegebenen Datei.
Habe aber mal die Möglichkeit der Angabe mehrerer Suchbegriffe (ggf. mit Sternchensuche) eingebaut.
Außerdem kann man im Code ja angeben, ob Groß/Kleinschreibung beachtet werden muss.
Mein Test "BNC,Auftr*,14101904", alle wurden erfolgreich gefunden....
Es soll also keine Zellen bezogene Suche sein, sondern eine Wert bezogene. Was soll das hier bedeuten? Die Suche erfolgt natürlich nach Werten/Begriffen in den Zellen der Sheets.
Option Explicit
Sub Suche_in_allen_Dateien()
Dim sSuch As String, iOutZeile As Long, xSuch As Integer, iAnz As Integer
Dim sSuchArr() As String
Dim WkB As Workbook, WSh As Worksheet
Dim oRange As Range
Dim sFirstAddress As String
Dim sPathname As String, sFilename As String
sPathname = "C:\Users\voltm\Desktop\MyTools\Daten\" '<<<anpassen>>>
sSuch = InputBox("Suchbegriff(e) kommagetrennt eingeben (ggf. mit *)")
If StrPtr(sSuch) = 0 Then Exit Sub
If sSuch = "" Then Exit Sub
sSuchArr = Split(sSuch, ",")
With Application
.ScreenUpdating = True
.EnableEvents = False
.Calculation = xlCalculationManual
End With
iOutZeile = 2
With ThisWorkbook.Sheets("Tabelle1")
.Cells.ClearContents
.Range("$A$1").Resize(1, 4).Value = Split("Mappe,Tabelle,Zelle,Suchbegriff", ",")
.Cells(2, "A").Value = "Suchbegriff '" & sSuch & "' wurde nicht gefunden!"
End With
'Alle Dateien entsprechend der Dir-Maske im Pfad durchgehen
sFilename = Dir(sPathname & "WA*.xls*") 'Nur Excel-Dateien ggf. anpassen
Do While sFilename <> ""
Set WkB = GetObject(PathName:=sPathname & sFilename)
If Not WkB Is Nothing Then
Application.StatusBar = WkB.Name & " wird gerade durchsucht"
For Each WSh In WkB.Worksheets
With WSh
For xSuch = 0 To UBound(sSuchArr)
Set oRange = .Cells.Find(What:=sSuchArr(xSuch), _
After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False)
If Not oRange Is Nothing Then
sFirstAddress = oRange.Address
Do
'Suche erfolgreich
With ThisWorkbook.Sheets("Tabelle1")
.Cells(iOutZeile, "A").Value = WkB.Name
.Cells(iOutZeile, "B").Value = WSh.Name
.Cells(iOutZeile, "C").Value = oRange.Address
.Cells(iOutZeile, "D").Value = oRange.Value
End With
iOutZeile = iOutZeile + 1
iAnz = iAnz + 1
DoEvents
Set oRange = .Cells.FindNext(oRange)
Loop Until oRange.Address = sFirstAddress
Set oRange = Nothing
End If
Next xSuch
End With
Next WSh
WkB.Close Savechanges:=False 'Schließen, ohne zu speichern
Set WkB = Nothing
End If
sFilename = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Es wurden " & iAnz & " Treffer gefunden!", vbInformation, "Suchbegriff suchen"
End Sub
