Anzeige
Archiv - Navigation
1716to1720
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Suche nach Wert in Dateien + Hyperlink
24.10.2019 09:05:17
MaBlu
Guten Morgen
ich habe ein Excel File das mir nach Dateien mit .SearchLike = "*APQP*.xls*" und durchsucht darin nach Namen die noch kein Abschussdatum haben. Das Funktioniert sehr gut, nur wenn eine Datei offen ist beginnt die suche und bricht dann einfach ab (File wird geschlossen) ohne Fehlermeldung, und keine Ausgabe in Datei kann man das anpassen?
Die Datei zum Suchen heisst Offene APQP Suchen.xlsm / Passwort: dobro
https://www.herber.de/bbs/user/132715.zip
Die Dateien zum Suchen darin heisst zB. 2238-APQP-V1.xlsx
https://www.herber.de/bbs/user/132716.zip
Ich hoffe mir kan hier jemand helfen das wäre Super
Liebe Grüsse Mablu

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suche nach Wert in Dateien + Hyperlink
30.10.2019 10:01:39
MaBlu
Hallo leider scheint mir niemand helfen zu können?
Eventuell hilft es wenn ich die Makros hier einstelle, ein Versuch ist es Wert!
Modul:
Option Explicit
Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Const MAX_PATH = 260
Private Const SHGFI_TYPENAME = &H400&
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
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
FI_FileName As String
FI_FullName As String
FI_FolderPath As String
FI_FileSize As Long
FI_LastAccess As Date
FI_LastModify As Date
FI_DateCreate As Date
End Type
Public Sub searchHyperlink()
'Suche nach APQP Dateien mit Datum hinter Namen, wenn kein Datum wird die Liste verlinkt!
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, strFirstAddress As String
On Error GoTo err_exit
strName = InputBox("Bitte gesuchten Namen eingeben!", "Hyperlinkliste", "?")
If strName  CStr(False) And (Len(strName)) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "T:\05_UP\80_Kunden\Neu\Kunden\" 'Startverzeichnis "T:\05_UP\ _
80_Kunden\Neu\Kunden\"
.Title = "Hyperlink erstellen - Ordnerwahl"
.ButtonName = "Start..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1) & "\"
End If
End With
If Len(strPath) Then
Set objThisSH = ThisWorkbook.Sheets("Hyperlink") 'Ausgabeblatt in dieser Datei
With objThisSH
.Unprotect Password:="dobro"
.Range("A2:A" & Rows.Count).ClearContents
.Range("A1") = "Dateien unerledigt für '" & strName & "'"
End With
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
If Left$(.Files(lngIndex).FI_FileName, 2)  "~$" Then
Set objWB = Workbooks.Open(.Files(lngIndex).FI_FullName, ReadOnly:= _
True)
If ProjectStart(objWB) Then
For Each objSh In objWB.Worksheets
If objSh.Name Like "CL-Phase*" Then
Set objFind = objSh.Range("H:H").Find(What:=strName,  _
Lookat:=xlWhole, _
LookIn:=xlValues, MatchCase:=False, SearchFormat:= _
False)
If Not objFind Is Nothing Then
strFirstAddress = objFind.Address
Do
If Not IsDate(objFind.Offset(0, 4).Value) 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
Set objFind = objSh.Range("H:H").FindNext(After: _
=objFind)
Loop Until objFind.Address = strFirstAddress
End If
End If
Next
End If
objWB.Close False
End If
Next
End If
End With
End If
objThisSH.Protect Password:="dobro"
End If
sub_exit:
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
Exit Sub
err_exit:
Call MsgBox("Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Programmfehler")
Resume sub_exit
End Sub

Private Function ProjectStart(ByRef probjWorkbook As Workbook) As Boolean
' hier wird das Initialdatum abgefragt! Wenn kein Datum Eingetragen ist wird die Liste nicht  _
berücksichtigt!
Dim objWorksheet As Worksheet
For Each objWorksheet In probjWorkbook.Worksheets
If objWorksheet.Name = "Projekt- und QM-Plan" Then
If IsDate(objWorksheet.Cells(4, 9).Value) Then
ProjectStart = True
Exit For
End If
End If
Next
Set objWorksheet = Nothing
End Function

Klassenmodul:
'*** Klassenmodul clsFileSearch ***
'// Module : clsFileSearch, Klassenmodul
'// Author : NEPUMUK at http://www.office-loesung.de/ftopic148247_0_0_asc.php
'// Created : 28. Mai 2007
'// Modified :
'// Purpose : FileSearch
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpSystemTime As SYSTEMTIME) As Long
Private Enum FILE_ATTRIBUTE
FILE_ATTRIBUTE_READONLY = &H1
FILE_ATTRIBUTE_HIDDEN = &H2
FILE_ATTRIBUTE_SYSTEM = &H4
FILE_ATTRIBUTE_DIRECTORY = &H10
FILE_ATTRIBUTE_ARCHIVE = &H20
FILE_ATTRIBUTE_NORMAL = &H80
FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean
Friend Property Get Files(lngIndex As Long) As FILEINFO
Files = mudtFiles(lngIndex)
End Property
Friend Property Get FileCount() As Long
FileCount = mlngFileCount
End Property
Friend Property Let FolderPath(strFolderPath As String)
mstrFolderPath = strFolderPath
End Property
Friend Property Let Extension(strExtension As String)
mstrExtension = strExtension
End Property
Friend Property Let SearchLike(strSearchLike As String)
mstrSearchLike = strSearchLike
End Property
Friend Property Let SubFolders(blnSubFolders As Boolean)
mblnSubFolders = blnSubFolders
End Property
Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
mblnCaseSenstiv = blnCaseSenstiv
End Property
Friend Property Let NewSearch(blnNewSearch As Boolean)
If blnNewSearch Then
Erase mudtFiles
mlngFileCount = 0
End If
End Property
FriEnd Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
Call FindFiles(mstrFolderPath)
If mlngFileCount > 1 And enmSortBy Sort_by_None Then _
Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
Execute = mlngFileCount
End Function
Private Sub FindFiles(ByVal strFolderPath As String)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1)  "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch  INVALID_HANDLE_VALUE Then
Call GetFilesInFolder(strFolderPath)
If mblnSubFolders Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If (strDirName  ".") And (strDirName  "..") Then _
Call FindFiles(strFolderPath & strDirName)
End If
Loop While FindNextFile(lngSearch, WFD)
End If
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler"
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, FI_FileName As String
Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1)  "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
If lngSearch  INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY)  FILE_ATTRIBUTE_DIRECTORY  _
Then
FI_FileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If IIf(mblnCaseSenstiv, FI_FileName, LCase$(FI_FileName)) Like _
IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
mlngFileCount = mlngFileCount + 1
ReDim Preserve mudtFiles(1 To mlngFileCount)
With mudtFiles(mlngFileCount)
.FI_FullName = strFolderPath & FI_FileName
.FI_FolderPath = strFolderPath
.FI_FileName = FI_FileName
.FI_FileSize = WFD.nFileSizeLow
FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.FI_DateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime. _
wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute,  _
udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.FI_LastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime. _
wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute,  _
udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.FI_LastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime. _
wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute,  _
udtSystemtime.wSecond))
End With
End If
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler"
End Sub

Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder  _
As SORT_ORDER)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim udtBuffer As FILEINFO, vntTemp As Variant
lngIndex1 = lngLBorder
lngIndex2 = lngUBorder
Select Case enmSortBy
Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).FI_FileName
Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).FI_FullName
Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).FI_FileSize
Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2). _
FI_LastAccess
Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2). _
FI_LastModify
Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2). _
FI_DateCreate
End Select
Do
Select Case enmSortBy
Case Sort_by_Name
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).FI_FileName  vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).FI_FileName
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Path
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).FI_FullName  vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).FI_FullName
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Size
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).FI_FileSize  vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).FI_FileSize
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Access
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).FI_LastAccess  vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).FI_LastAccess
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Modyfy
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).FI_LastModify  vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).FI_LastModify
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Date_Create
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).FI_DateCreate  vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).FI_DateCreate
lngIndex2 = lngIndex2 - 1
Loop
End If
End Select
If lngIndex1  lngIndex2
If lngLBorder 

ich hoffe auf Rückmeldung
Freundliche Grüsse MaBlu
Anzeige

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige