AW: Nach Zellen Inhalt suchen
22.01.2023 04:08:52
Nepumuk
Hallo Marcus,
mein Fehler, da war eine falsche Abfrage drin. Jetzt gib mal als Suchbegriff Bestellung ein:
Option Explicit
Option Compare Text
Public Enum SORT_BY
Sort_by_None
Sort_by_Name
Sort_by_Path
Sort_by_Size
Sort_by_Last_Access
Sort_by_Last_Modyfy
Sort_by_Date_Create
End Enum
Public Enum SORT_ORDER
Sort_Order_Ascending
Sort_Order_Descending
End Enum
Public Type FILEINFO
Filename As String
Path As String
Size As Long
LastAccess As Date
LastModify As Date
DateCreate As Date
End Type
Public Sub SearchFiles()
Dim wksInhalt As Worksheet
Dim objWorkbook As Workbook
Dim objFileSearch As clsFileSearch
Dim ialngIndex As Long, lngFileCount As Long, lngRow As Long
Dim strFolder As String, strSearch As String
strSearch = InputBox("Suchbegriff?", "Eingabe")
If StrPtr(strSearch) = 0 Then Exit Sub
strFolder = ThisWorkbook.Worksheets("Start").Cells(1, 2).Text
If strFolder = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\" 'anpassen
If .Show Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
lngRow = 2
For Each wksInhalt In ThisWorkbook.Worksheets
If wksInhalt.Name = "Inhalt" Then Exit For
Next
If wksInhalt Is Nothing Then
Set wksInhalt = Worksheets.Add
wksInhalt.Name = "Inhalt"
End If
With wksInhalt
Call .Activate
Call .Columns("A:C").Clear
With .Range("A1:B1")
.Value = Array("Pfad", "Dateiname")
.Font.Bold = True
End With
End With
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls*"
.FolderPath = strFolder
.SearchLike = "*"
.SubFolders = True
lngFileCount = .Execute(Sort_by_Path, Sort_Order_Ascending)
For ialngIndex = 1 To lngFileCount
If Left$(.Files(ialngIndex).Filename, 2) > "~$" Then
Set objWorkbook = GetObject(PathName:=.Files(ialngIndex).Path)
If objWorkbook.Worksheets(1).Cells(1, 3).Text = strSearch Then
wksInhalt.Cells(lngRow, 1).Value = .Files(ialngIndex).Path
Call wksInhalt.Hyperlinks.Add(Anchor:=wksInhalt.Cells(lngRow, 2), _
Address:=.Files(ialngIndex).Path, TextToDisplay:=.Files(ialngIndex).Filename)
lngRow = lngRow + 1
End If
Call objWorkbook.Close(SaveChanges:=False)
End If
Next
End With
Call wksInhalt.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objFileSearch = Nothing
Set wksInhalt = Nothing
Set objWorkbook = Nothing
End Sub
Gruß
Nepumuk