|
Quick&Dirty
Option Explicit
Sub Test()
Suchen
Suchen "E:\Temp"
End Sub
Sub Suchen(Optional ByVal Ersatz As String)
'
Dim Laufwerk As String, Dateien As String, Datei As String
Dim z As Long, lrw As Long
'Ersze Zeile, in der eine Eintragung erfolgt
z = 2
'letze Zeile zum Löschen
lrw = Cells(Rows.Count, 1).End(xlUp).Row
'Alte Eintragungen löschen
With Range(Cells(z, 1), Cells(lrw, 1)) '[a2:a64000] = "" -> [ ] ist verpönt
.ClearContents
.ClearHyperlinks
End With
'Den Variablen Laufwerk und Dateien kann
'auch ein direkter Wert zugewiesen werden.
'Ersatz: ... = "C:\Eigene Dateien"
Laufwerk = ThisWorkbook.Path ' ggf. & "\neue_pdfs\"
If Len(Ersatz) Then Laufwerk = Ersatz
If Right(Laufwerk, 1) <> "\" Then Laufwerk = Laufwerk & "\"
'Laufwerk = "E:\Eigene Dateien\Eigene Bilder\"
'If Laufwerk = "" Then Exit Sub
'Ersatz: Dateien = "*.*"
Dateien = InputBox("Nach welchen Dateien soll in" & _
Chr(10) & " " & Laufwerk & Chr(10) & _
"gesucht werden (z. B. *.xls)?", _
"Dateityp", "*.pdf")
'Dateien = "*.pdf"
If Dateien = "" Then Exit Sub
Datei = Laufwerk & Dateien
'Dateisuche Laufwerk, Dateien
Datei = Dir(Datei)
Do While Datei <> ""
Cells(z, 1).Hyperlinks.Add anchor:=Cells(z, 1), Address:=Datei
z = z + 1
Datei = Dir()
Loop
End Sub
|