Inhaltsverzeichnis mit Link

Hallo zusammen,
ich möchte gerne in einer Exceldatei Inhaltsverzeichnis aus dem aktuellen Ordner oder aus Unterordner die Namen der vorhandenen Dateien in 4 Spalten aufgelistet haben.
Spalte B (Dateinamen die mit GB_ beginnen)
Spalte E (Dateinamen die mit BA_ beginnen)
Spalte H (Dateinamen die mit BG_ beginnen)
Spalte K (Dateinamen die mit XX_ beginnen)
die sollten Alphabetisch sortiert mit Dateiname und Verlinkung zur Datei aufgelistet werden.
Die Dateien können Excel, Word oder auch pdf sein.
Hat vielleicht jemand eine Lösung für mich?
eine allgemeine Auflistung bekomme ich hin, aber mit der gewünschten Sortierung und einem zusätzlichen Link nicht.
Danke für eure Hilfe.
Gruß Ulli
Vielen Dank vorab.
Gruß Ulli
https://www.herber.de/bbs/user/140173.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
versuch es mal damit


Sub alle_Dateien_Verzeichnis() '
On Error GoTo Fehler
Dim Pfad As String, Ext1 As String, Ext2 As String, Ext3 As String
Dim Datei As String, Spalte As Integer, LR As Integer
Dim ArrSp, Z1 As Integer, i As Integer, RNG As Range
Pfad = "E:\Excel\Temp\" '**** mit \
Ext1 = ".xls"
Ext2 = ".doc"
Ext3 = ".pdf"
ArrSp = Array(1, 4, 7, 10) ' Zielspalten für die unterschiedlichen Dateinamen
' Array beginnt bei 0
Z1 = 4 'erste Zeile mit Daten
With Sheets("Tabelle1")
'reset
With .UsedRange.Offset(Z1 - 1)
.ClearContents
.Hyperlinks.Delete
End With
Datei = Dir(Pfad & "*.*")
Do While Len(Datei) > 0
'Nur xls,doc und pdf
If InStr(Datei, Ext1) > 0 Or InStr(Datei, Ext2) > 0 Or InStr(Datei, Ext3) > 0 Then
Select Case Left(Datei, 2) 'ersten 2 Zeichen von Dateiname
Case "GB"
Spalte = ArrSp(0)
Case "BA"
Spalte = ArrSp(1)
Case "BG"
Spalte = ArrSp(2)
Case "XX"
Spalte = ArrSp(3)
Case Else
Spalte = 0
End Select
If Spalte > 0 Then
LR = .Cells(.Rows.Count, Spalte).End(xlUp).Row + 1 'erste Freie Zeile der  _
Spalte
.Cells(LR, Spalte) = WorksheetFunction.Max(.Columns(Spalte)) + 1 '  _
Nummerierung eintragen
.Cells(LR, Spalte + 1) = Datei ' Dateiname eintragen
.Hyperlinks.Add Anchor:=.Cells(LR, Spalte + 1), _
Address:=Pfad & Datei, TextToDisplay:=Datei
End If
End If
Datei = Dir() ' nächste Datei
Loop
For i = 0 To 3 ' Sortieren
LR = .Cells(.Rows.Count, ArrSp(i)).End(xlUp).Row
Set RNG = .Cells(Z1, ArrSp(i) + 1).Resize(LR - Z1 + 1, 1)
With .Sort
.SortFields.Clear
.SortFields.Add2 Key:=RNG, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange RNG
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next
End With
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread