Links sortieren nach Verzeichniss

Sub LinkE_Click() Const FILE_PATH As String = "E:\" Dim lngRow As Long Dim strFilename As String Application.ScreenUpdating = False 'Löscht alte einträge Range("A2:A5000").ClearContents lngRow = 1 Call Range(Cells(1, 1), Cells(Rows.Count, 1)).ClearContents strFilename = Dir$(FILE_PATH & "*.*") Do Until strFilename = vbNullString lngRow = lngRow + 1 Call ActiveSheet.Hyperlinks.Add(Anchor:=Cells(lngRow, 1), _ Address:=FILE_PATH & strFilename, _ TextToDisplay:=Left$(strFilename, InStrRev(strFilename, ".") - 1)) strFilename = Dir$ Loop 'Schriftgröße einstellen Columns(1).Font.Size = 15 Columns(2).Font.Size = 15 'Spaltenbreite einstellen Columns("A:A").ColumnWidth = 53.53 Columns("B:B").ColumnWidth = 47.76 Columns("C:C").ColumnWidth = 45.53 'Schrift Farbe einstellen With Range("A2:C5000") .Interior.Color = vbBlack .Font.Color = RGB(255, 192, 0) End With Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Vorsicht mit CALL, der Befehl ist zum Aufruf von Unterprogrammen reserviert. Mich wundert das Excel sich an Call vor Range nicht stört!
Auf Call vor Hyperlink kannst du verzichten wenn du die Klammer weglässt. AUf den Call für ClearContents kannst du ganz verzichten. Dafür habe ich den ersten Clear Befehl erweitert. Ist doch viel einfacher!
Neu eingefügt habe ich den Befehl in der Do Loop Schleife um das File-Datum mit aufzulisten. Dann kannst du die Daten nach diesem Datum sortieren! In welcher Spalte du die Zeit auflisten willst must duentscheiden, und den Code ggf. an diese Spalte anpassen. Dann sollte es klappen. Hier der geänderte Ciode bis zur Sortier Routine, der Restbleibt wie vorher.
mfg Piet

Sub LinkE_Click()
Const FILE_PATH As String = "D:\_Excel Heute\"
Dim lngRow As Long
Dim strFilename As String
Application.ScreenUpdating = False
'Löscht alte einträge
Range("A2:A" & Rows.Count).ClearContents
lngRow = 1
'### Überflüssig!!
'call Range(Cells(1, 1), Cells(Rows.Count, 1)).Select 'ClearContents
strFilename = Dir$(FILE_PATH & "*.*")
Do Until strFilename = vbNullString
lngRow = lngRow + 1
ActiveSheet.Hyperlinks.Add anchor:=Cells(lngRow, 1), _
Address:=FILE_PATH & strFilename, TextToDisplay:= _
Left$(strFilename, InStrRev(strFilename, ".") - 1)
'** Time in Spalte D einfügen (oder andere Spalte)
Cells(lngRow, 4) = FileDateTime(FILE_PATH & strFilename)
strFilename = Dir$
Loop
'### Sortierroutine für Spalte D einbauen!!
Range("A2:D5000").Sort Key1:=Range("D2"), Order1:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'### Ende

Hallo
setze den Befehl Create Object bitte VOR strFilename = Dir$ und schaue ob es dann klappt. Alternativ habe ich noch einer andere Variante für dich.
Das erste Makro ist das Original zum auflisten von 33 Dateieigenschaften eines Ordners. Daraus abgeleitet habe ich die Kurzversion für deine Zwecke. Teste das Makro erst mal in einer Testdatei, bis es so läuft wie du es brauchst. Dann setze in der Testdatei dein Makro ein und ersetze den Do Loop Teil durch die For Next Version. Bastele solange bis es klappt. Viel Glück beim basteln und testen.
Im zweiten Makro findest du - Cells(i, 1) = strFilename für Dateiname ohne Endung. Die Zeile darunter mit der Datei-Endung, z.B. .pdf usw.
Es bleibt dir überlassen welche als Hyperlink besser geeignet ist. Statt Dir$ ist das eine "ShellObject" Version. Gibt es auch noch in FSO.
mfg Piet


Sub Datei_Eigenschaften()
Const FILE_PATH As String = "D:\_Excel Heute\"
Worksheets("Test").Select
Cells.Clear
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(FILE_PATH)
i = 2
For j = 0 To 320
Cells(1, j + 2) = j & " " & objFolder.GetDetailsOf(, j)
Next
For Each strFilename In objFolder.Items
Cells(i, 1) = strFilename
For j = 0 To 320
Cells(i, j + 2) = Trim(objFolder.GetDetailsOf(strFilename, j))
Next
i = i + 1
Next
Columns.AutoFit
End Sub

'** Hier die Kurzversion für deine Zwecke!


Sub Datei_eigenschaften_2()
Const FILE_PATH As String = "D:\_Excel Heute\"
Worksheets("Test").Select
Cells.Clear
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(FILE_PATH)
i = 2
For Each strFilename In objFolder.Items
Cells(i, 1) = strFilename   'Dateiname OHNE Endung. unten mit Endung
'Cells(i, 1) = strFilename & objFolder.GetDetailsOf(strFilename, 164)
Cells(i, 3) = objFolder.GetDetailsOf(strFilename, 4)
i = i + 1
Next
End Sub

Beliebteste Forumthreads (12 Monate)

Links sortieren nach Verzeichniss

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread