Private Sub CommandButton1_Click()
Dim pfad As String, such As String
Dim Text As String, xxl As String
Dim i As Integer, y As Integer, z As Integer
Dim info As Integer, x As Integer, anz As Integer
Dim fs
Set fs = Application.FileSearch
pfad = InputBox("Geben Sie den Pfad ein", , "C:\Eigene Dateien")
If pfad = "" Then Exit Sub
With fs
.LookIn = pfad
.Filename = "*.*"
'wenn der Pfad nicht existiert Programm abbrechen
If Dir(pfad, vbDirectory) = "" Then
MsgBox "Falsche Pfadangabe ! Das Verzeichnis" & _
vbCrLf & "' " & pfad & " '" & _
vbCrLf & "existiert nicht !", _
vbExclamation, "Fehlermeldung"
Exit Sub
End If
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
z = Len(.LookIn)
such = "\"
Cells(2, 2) = pfad & " " & .FoundFiles.Count & " Dateien"
y = 3
For i = 1 To .FoundFiles.Count
Cells(y, 2) = .FoundFiles(i)
Text = Cells(y, 2)
anz = Len(Cells(y, 2))
such = "\"
For x = 1 To anz
info = InStr(info + 1, Text, such)
If info = 0 Then GoTo weiter
Cells(y, 2) = Right(Text, anz - info)
xxl = Cells(y, 2)
With ActiveSheet
.Hyperlinks.Add Anchor:=.Cells(y, 2), Address:=Text, _
TextToDisplay:=xxl
End With
Next x
weiter:
y = y + 1
Next i
Columns("B:B").AutoFit
Else
MsgBox "Keine Dateien gefunden"
End If
End With
With Columns("B:B").Font
.Name = "Arial"
.FontStyle = "Standard"
.Underline = xlUnderlineStyleNone
.ColorIndex = 5
End With
With Cells(2, 2).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 10
.ColorIndex = xlAutomatic
.Bold = True
End With
End Sub
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen