Makro für das importieren von Dateinamen mit Hyperlinks aus einem Ordner und seine Unterordnern?
Hallo zusammen,
ich würde gerne eine Excel erstellen in der ich aus einem Ordner und seinen Unterordnern die Dateinamen auflisten kann, mit Hyperlinks ohne Dateipfad nur mit dem Namen der Datei. Dan nach würde ich gerne diese Dateinamen mit den Einträgen einer anderen Zeile verbinden, sodass wenn der Dateiname der importierten Dateien z. B. Apfel ist und in einer andern Zeile auch Apfel steht, diese automatisch in dieselbe Spalte sortiert werden. Gibt es dazu einen Makro code denn ich benutzen könnte oder irgendwie andere Optionen? Die exportierten Dateinamen sollen übrigen in eine bestimmte Spalte und nicht ganz am Anfang der Tabelle stehen.
1 Antwort
Hallo, nachdem ich so ein Ähnliches Problem gelöst hatte, habe ich es für dich ein bisschen umgebaut. So schaut das Endergebnis aus:
Spalte A wäre dein Begriff (Apfel).
In B1 gibst du den Pfad ein, unter dem gesucht werden soll.
Das Makro sucht alle Dateien in diesem Pfad, auch in Ordnern, Unterordnern, Unterunterordnern, usw..
Es schreibt in Spalte B den Dateinamen und verlinkt ihn.
In Spalte C steht der Pfad, in dem die Datei steht.
Wenn der selbe Name in mehreren Ordnern gefunden wird färbt sich dein Begriff rot, es stehen alle Pfade drin, der Link geht auf den ersten Pfad.
Falls Dateien gefunden werden, die nicht in deiner Liste sind, werden diese unten angehängt.
Und das ist der Code, du kannst die Spalten nach deinem Bedarf ändern (siehe fett gedrucktes):
Option Explicit
Global Lesespalte As String, Zählspalte As String, Linkspalte As String, Pfad As String, Ende As Long, Z As Long, Dateiname As String, Datei As String, Punkt As Integer, k As Long, erster As Boolean
Sub Startroutine()
On Error Resume Next
ActiveSheet.ShowAllData
Lesespalte = "A"
Linkspalte = "B"
Zählspalte = "C"
erster = True
Ende = Cells.SpecialCells(xlLastCell).Row
Range(Lesespalte & "2:" & Lesespalte & Ende).Font.ColorIndex = 0
Range(Linkspalte & "2:" & Linkspalte & Ende).ClearContents
Range(Zählspalte & "1").ClearContents
'fehlende Dateien anmerken
For Z = 2 To Ende
Range(Zählspalte & Z) = "keine Datei gefunden"
Next Z
Call Ordnerlesen(Range(Linkspalte & "1").Value)
End Sub
Private Sub Ordnerlesen(ByVal sPath As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
'Dateien aus Hauptordner auslesen
Set oFolder = oFSO.getfolder(sPath)
If erster Then
erster = False
For Each oFile In oFolder.Files
Pfad = oFolder.Path
GoSub schreiben
Next oFile
End If
'Unterverzeichnisse auslesen
For Each oSubFolder In oFolder.subfolders
'Alle Dateien auflisten
For Each oFile In oSubFolder.Files
Pfad = oSubFolder.Path
GoSub schreiben
Next oFile
'Unterverzeichnisse im Unterverzeichnis auslesen (rekursiv)
Call Ordnerlesen(oSubFolder.Path)
Next oSubFolder
GoTo aus
schreiben:
Dateiname = oFile.Name
Punkt = 0: Punkt = InStr(Dateiname, ".")
If Punkt = 0 Then Datei = Dateiname Else Datei = Left(Dateiname, Punkt - 1)
Z = 0: Z = Range(Lesespalte & ":" & Lesespalte).Find(Datei, lookat:=xlWhole, MatchCase:=False).Row
If Z = 0 Then Z = Cells.SpecialCells(xlLastCell).Row + 1
Cells(Z, Lesespalte) = Datei
Cells(Z, Linkspalte) = Dateiname
Cells(Z, Linkspalte).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Replace(Pfad & "\" & Dateiname, " ", "%20"), TextToDisplay:=Dateiname
Range(Zählspalte & 1) = Range(Zählspalte & 1) + 1
If Range(Zählspalte & Z) = "keine Datei gefunden" Then
Range(Zählspalte & Z) = Pfad
Else
Range(Zählspalte & Z) = Pfad & Chr$(10) & Range(Zählspalte & Z)
Range(Lesespalte & Z).Font.ColorIndex = 3
End If
DoEvents
Return
aus:
Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing
End Sub
