Dim dateien()
Option Explicit
Sub DateienLesen2()
Dim DateiName As String
Dim quelle As String
Dim i As Long
Dim j As Long
Dim Dateialt As String
Dim zeilealt As Long
Dim Namekurz As String
Dim Blatt As Object
Dim gefunden As Boolean
Dim suchwert As Variant
Dim suche As Variant
Dim oAdoConnection
Dim sAdoConnectString
Dim oAdoRecordset
Dim oAdoRecordset2
Dim ssql
Dim satz
Dim k
Application.ScreenUpdating = False
Dateialt = ThisWorkbook.name
zeilealt = 1
ActiveSheet.Columns(1).ClearContents
suchwert = InputBox("Zu suchenden Wert eingeben!", "Suchtexteingabe")
If suchwert = "" Then
MsgBox "Sie haben keinen Wert eingegeben oder Abbrechen angeklickt. Das Program wird beendet.", , "Abbruch Eingaben"
End
End If
ReDim dateien(0)
dateien(0) = 0
quelle = "V:\0101\SCHULEN\0-FAHRT"
If Right(quelle, 1) = "\" Then quelle = Left(quelle, Len(quelle) - 1)
If Dir(quelle & "\") = "" Then
MsgBox "Der Pfad wurde nicht gefunden!"
End
End If
Call txtsuchen2("1" & quelle)
If dateien(0) = 0 Then
MsgBox "Keine .txt Dateien gefunden!"
Else
For i = 1 To dateien(0)
DateiName = dateien(i)
Namekurz = Right(DateiName, InStr(1, StrReverse(DateiName), "\") - 1)
gefunden = False
Set oAdoConnection = CreateObject("ADODB.CONNECTION")
If Val(Application.Version) > 11 Then
sAdoConnectString = "Provider=Microsoft.ACE.OLEDB.12.0; Extended Properties='Excel 12.0 Xml;HDR=No';Data Source=" & DateiName
Else
sAdoConnectString = "Provider=Microsoft.ACE.OLEDB.12.0; Extended Properties='Excel 8.0;HDR=No';Data Source=" & DateiName
End If
oAdoConnection.Open sAdoConnectString
Set oAdoRecordset = CreateObject("ADODB.RECORDSET")
Set oAdoRecordset = oAdoConnection.OpenSchema(20)
While Not oAdoRecordset.EOF
ssql = "SELECT * from " & Chr(91) & oAdoRecordset.Fields(2).Value & Chr(93)
Set oAdoRecordset2 = CreateObject("ADODB.RECORDSET")
oAdoRecordset2.Open ssql, oAdoConnection, adOpenKeyset, adLockReadOnly
If Not oAdoRecordset2.EOF Then
satz = oAdoRecordset2.GetRows
For Each k In satz
If k <> 0 Then If InStr(1, k, suchwert, vbTextCompare) Then gefunden = True
Next
End If
oAdoRecordset.MoveNext
Wend
oAdoRecordset.Close
oAdoRecordset2.Close
oAdoConnection.Close
Set oAdoRecordset = Nothing
Set oAdoRecordset2 = Nothing
Set oAdoConnection = Nothing
If gefunden = True Then
ActiveSheet.Hyperlinks.Add anchor:=ActiveSheet.Cells(zeilealt, 1), Address:=DateiName, TextToDisplay:=Namekurz
zeilealt = zeilealt + 2
End If
Next i
End If
End Sub
Function txtsuchen2(pfads As String)
Dim suche
Dim i As Long
Dim quelle As String
Dim oOrdner
Dim oDateien
Dim datsystem
Dim knoten
Dim datei
Dim ablage
Dim dname As String
Dim onam As String
Dim anfang
Set datsystem = CreateObject("Scripting.FileSystemObject")
quelle = pfads
anfang = Left(pfads, 1)
quelle = Right(pfads, Len(pfads) - 1)
ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
Set knoten = datsystem.GetFolder(quelle)
Set oDateien = knoten.Files
Set oOrdner = knoten.SubFolders
For Each ablage In oOrdner
onam = ablage.name
If Left(onam, 1) <> "." Then
If anfang <> "x" Then
If anfang = 2 Then
Call txtsuchen2("x" & ablage.Path)
Else
Call txtsuchen2((anfang + 1) & ablage.Path)
End If
Else
If InStr(1, onam, "16", 1) > 0 Or InStr(1, onam, "Region", 1) > 0 Or InStr(1, onam, "Rahmenvertrag", 1) > 0 Or InStr(1, onam, "Abrechnung", 1) > 0 Then
If InStr(1, onam, "Änderung", 1) > 0 Or InStr(1, onam, "Fahrpl", 1) > 0 Or InStr(1, onam, "14", 1) > 0 Or InStr(1, onam, "13", 1) > 0 Or InStr(1, onam, "12", 1) > 0 Or InStr(1, onam, "11", 1) > 0 Or InStr(1, onam, "10", 1) > 0 Then
Else
Call txtsuchen2("x" & ablage.Path)
End If
End If
End If
End If
Next ablage
If oOrdner.Count = 0 Then
For Each datei In oDateien
dname = datei.name
If Left(dname, 1) <> "." Then
If Right(dname, 4) = ".xls" Then
If (InStr(1, dname, "_Planung", 1) > 0 Or InStr(1, dname, "_planung", 1) > 0 Or InStr(1, dname, "_PLANUNG", 1) > 0) And InStr(1, dname, "2016", 1) > 0 Then
dateien(0) = dateien(0) + 1
ReDim Preserve dateien(dateien(0))
dateien(dateien(0)) = datei.Path
End If
End If
End If
Next datei
End If
Set datsystem = Nothing
Set knoten = Nothing
Set oDateien = Nothing
Set oOrdner = Nothing
Application.ScreenUpdating = True
End Function