Suche Zeile für Zeile

Public Sub searchHyperlink()
Dim objFileSearch As clsFileSearch
Dim objWB As Workbook, objSh As Worksheet, objThisSH As Worksheet, objFind As Range
Dim lngIndex As Long, lngRow As Long
Dim strPath As String, strName As String
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
strName = InputBox("Bitte gesuchten Namen eingeben!", "Hyperlinkliste", "?")
If strName  CStr(False) And (Len(strName)) Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "T:\05_UP\80_Kunden\Neu\Kunden\"  'Startverzeichnis
.Title = "Hyperlink erstellen - Ordnerwahl"
.ButtonName = "Start..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1)  "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
ActiveSheet.Unprotect Password:="dobro"
Set objThisSH = ThisWorkbook.Sheets("Hyperlink") 'Ausgabeblatt in dieser Datei
objThisSH.Range("A2:A" & Rows.Count).ClearContents
objThisSH.Range("A1") = "Dateien unerledigt für '" & strName & "'"
lngRow = 2
Set objFileSearch = New clsFileSearch
With objFileSearch
.NewSearch = True
.CaseSenstiv = False
.Extension = "*.xls*"
.FolderPath = strPath
.SearchLike = "*APQP*.xls*"
.SubFolders = True
If .Execute(Sort_by_Date_Create, Sort_Order_Descending) > 0 Then
For lngIndex = 1 To .FileCount
'Set objWB = Workbooks.Open(.Files(lngIndex).FI_FullName)
Set objWB = Workbooks.Open(.Files(lngIndex).FI_FullName, ReadOnly:=True)
For Each objSh In objWB.Worksheets
If objSh.Name Like "CL-Phase*" Then
Set objFind = objSh.Range("H:H").Find(What:=strName, Lookat:=xlWhole, _' hier  _
sollte Zeile für Zeile abgeklärt werden?
LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
If Not objFind Is Nothing Then
If objFind.Offset(0, 4) = "" Or Not IsDate(objFind.Offset(0, 4)) Then
objThisSH.Hyperlinks.Add Anchor:=objThisSH.Cells(lngRow, 1), _
Address:=objWB.FullName, TextToDisplay:=objWB.FullName
objThisSH.Cells(lngRow, 1).Style = "Hyperlink"
lngRow = lngRow + 1
Exit For
End If
End If
End If
Next
objWB.Close False
Next
End If
End With
End If
ActiveSheet.Protect Password:="dobro"
End If
ErrorHandler:
With Application
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Set objFileSearch = Nothing
Set objThisSH = Nothing
Set objWB = Nothing
Set objSh = Nothing
Set objFind = Nothing
End Sub