AW: Abfrage überspringen - funktioniert doch nicht
16.05.2023 11:22:43
volti
Hallo Mischi,
schau mal, ob Du damit wieterkommst....
Sub Suche_in_allen_Dateien_xls()
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, sEinschl As String
If MsgBox( _
prompt:="Zum Durchsuchen von xlsm-Dateien vorher unter Optionen: Trust Center Einstellung anzupassen" & vbCrLf & _
"OK: sind eingestellt -> weiter" & vbCrLf & _
"oder" & vbCrLf & _
"Abbrechen -> müssen noch geändert werden", _
Buttons:=vbOKCancel) > vbOK Then '-------------------------------------------------------------------(4)
Exit Sub
End If '-------------------------------------------------------------------------------------(4 auch hier mgl?)
' sPathname = "C:\MSch\Excel\" '>>
sPathname = ThisWorkbook.Sheets("Suche").Cells(2, 2).Value
' sSuch = InputBox("Suchbegriff(e) kommagetrennt eingeben (ggf. mit *)")
sSuch = ThisWorkbook.Sheets("Suche").Cells(3, 2).Value
sEinschl = ThisWorkbook.Sheets("Suche").Cells(4, 2).Value
'If StrPtr(sSuch) = 0 Then Exit Sub ' nur bei Inputbox erforderlich, kann weg
If sSuch = "" Then Exit Sub
sSuchArr = Split(sSuch, ",")
With Application
.ScreenUpdating = False
.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 & "*.xls*") 'Nur Excel-Dateien ggf. anpassen
Do While sFilename > "" '----------------------------------------------------------------(Loop)
' nur Dateien durchsuchen, die sEinschl im Dateinamen enthalten
If InStr(1, sFilename, sEinschl, 1) > 0 Then '1: vbTextCompare --------(3) "optionaler" Startwert muß angegeben werden sonst Typenunverträglich!?
'Set WkB = GetObject(PathName:=sPathname & sFilename) '------------------------- "öffnen" der Datei =>
Application.DisplayAlerts = False
Set WkB = Workbooks.Open(Filename:=sPathname & sFilename, UpdateLinks:=False)
Application.DisplayAlerts = True
If Not WkB Is Nothing Then '---------------------------------------(2)
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 '-----------------------(1)
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 '----------------------------------------------(1)
Next xSuch
End With
Next WSh
WkB.Close Savechanges:=False 'Schließen, ohne zu speichern
Set WkB = Nothing
End If '------------------------------------------------------------(2)
End If '-----------------------------------------------------------------------(3)
sFilename = Dir
Loop '----------------------------------------------------------------------------------------(Loop)
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Es wurden " & iAnz & " Treffer gefunden!", vbInformation, "Suchbegriff suchen"
MsgBox "Trust Center Einstellung wieder zurücksetzen!", vbInformation
End Sub
Gruß Karl-Heinz