Option Explicit
Sub InSpalte()
Dim TextDatei As String
Dim hf As Integer
Dim Zeilen() As String, Vergleich As String
Dim letzteZ As Long, x As Long, flag As Boolean
On Error GoTo Fehler
Application.ScreenUpdating = False
hf = FreeFile
TextDatei = ThisWorkbook.Path & "\xlsgefunden.txt"
Open TextDatei For Input As hf
Zeilen = Split(Input(LOF(hf), hf), vbNewLine)
If UBound(Zeilen) = -1 Then
Call MsgBox("kein Treffer!", vbCritical, "Abbruch")
Exit Sub
End If
With Range("B1")
.CurrentRegion.Clear
.CurrentRegion.ClearHyperlinks
.Resize(UBound(Zeilen), 1).Value = Application.Transpose(Zeilen)
End With
Fehler:
Close hf
Application.ScreenUpdating = True
If Err.Number = 0 Then
Select Case MsgBox("Nur die Dateien am Ende eines Astes?", _
vbYesNoCancel Or vbQuestion Or vbDefaultButton1, "Einschränkungen")
Case vbYes
flag = NurAmPfadende()
Case vbNo
Case vbCancel
Exit Sub
End Select
flag = NurinOrdnern()
If flag = True Then Call NeueLinks
End If
End Sub
Private Function NurAmPfadende() As Boolean
Dim letzteZ As Long, x As Long
Dim Vergleich As String
On Error GoTo Fehler
Application.ScreenUpdating = False
letzteZ = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For x = letzteZ To 2 Step -1
Vergleich = Range("B" & x).Value
Vergleich = Left(Vergleich, InStrRev(Vergleich, "\") - 1)
If InStr(Range("B" & x - 1).Value, Vergleich) > 0 Then Rows(x).Delete
Next x
NurAmPfadende = True
Fehler:
Application.ScreenUpdating = True
End Function
Private Function NurinOrdnern() As Boolean
Dim letzteZ As Long, x As Long
Dim Suchwert As String
On Error GoTo Fehler
Application.ScreenUpdating = False
Suchwert = InputBox("Zu durchsuchenden Ordner eingeben!", "Ordnername")
If Suchwert = "" Then
NurinOrdnern = True
Exit Function
End If
letzteZ = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For x = letzteZ To 2 Step -1
If InStr(Range("B" & x - 1).Value, Suchwert) = 0 Then Rows(x).Delete
Next x
letzteZ = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
NurinOrdnern = True
Fehler:
Application.ScreenUpdating = True
End Function
Private Sub NeueLinks()
Dim letzteZ As Long, x As Long
Dim Suchwert As String
On Error GoTo Fehler
Suchwert = InputBox("Zu suchenden Wert eingeben!", "Suchtexteingabe")
If Suchwert = "" Then Exit Sub
Application.ScreenUpdating = False
letzteZ = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For x = 1 To letzteZ
Next x
Fehler:
Application.ScreenUpdating = True
End Sub