(05.08.2020, 10:21)volti schrieb: [ -> ][...]
Lade doch mal eine von den zu durchsuchenden Dateien hier hoch, dann kann man da mal schauen.
viele Grüße
Karl-Heinz
mach ich gerne
nochmals zum Hintergrund: Ziel der Suche ist es, aus allen im Ordner vorhandenen Prüfprotokollen dasjenige zu finden, in dem die eine oder andere Seriennummer enthalten ist ... wie z.B. in der beigefügten Datei die "14101904" für die Frontbaugruppe (natürlich kämen andere Baugruppen bzw. halt Seriennummern je nach Suchanfrage auch in Frage). Es soll also keine Zellen bezogene Suche sein, sondern eine Wert bezogene.
Grüße
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
viele Grüße aus Freigericht
Karl-Heinz