14.07.2015, 16:20
Liebe Forengemeinde,
ich möchte in Excel die Daten von einem Laufwerk als Hyperlink darstellen.
Mit folgendem Code wird mir auch in der ersten Spalte der Dateiname als Hyperlink und in der zweiten Spalte der zugehörige Dateipfad angezeigt.
Allerdings hätte ich noch gerne, dass in der dritten Spalte das Erstellungsdatum der jeweiligen Datei, in der vierten Spalte das Datum der letzten Änderung der Datei und in der fünften Spalte das Datum des letzten Zugriffs der Datei dargestellt wird.
Wie muss ich hierzu den Code ergänzen bzw. abändern? Bin leider noch Anfänger in Sachen VBA.
ich möchte in Excel die Daten von einem Laufwerk als Hyperlink darstellen.
Mit folgendem Code wird mir auch in der ersten Spalte der Dateiname als Hyperlink und in der zweiten Spalte der zugehörige Dateipfad angezeigt.
Allerdings hätte ich noch gerne, dass in der dritten Spalte das Erstellungsdatum der jeweiligen Datei, in der vierten Spalte das Datum der letzten Änderung der Datei und in der fünften Spalte das Datum des letzten Zugriffs der Datei dargestellt wird.
Wie muss ich hierzu den Code ergänzen bzw. abändern? Bin leider noch Anfänger in Sachen VBA.
Code:
Option Explicit
Private strList() As String
Private lngCount As Long
Private sPfad As String
Public Sub DateienAuflisten()
Dim i As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
OrdnerAuswählen
lngCount = 0
SearchFiles sPfad, "*"
If lngCount = 0 Then
MsgBox "Es wurde in der Ordnerstruktur" & sPfad & " keine Dateien gefunden!"
Exit Sub
End If
With ThisWorkbook
On Error Resume Next
.Worksheets("Datei Übersicht").Delete
On Error GoTo 0
.Worksheets.Add(After:=Worksheets(ThisWorkbook.Worksheets.Count)).Name = "Datei Übersicht"
End With
With ActiveSheet
.Range(.Cells(1, 1), .Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 2), .Cells(lngCount, 2)).Replace What:=sPfad & "\", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
For i = 0 To lngCount - 1
With .Cells(i + 1, 1)
.Select
.Cells(i + 1, 1).Hyperlinks.Add Anchor:=Selection, Address:=strList(1, i), TextToDisplay:=strList(0, i)
End With
Next i
.Range("A:A").EntireColumn.AutoFit
.Rows(1).Insert
With Range(Cells(1, 1), Cells(1, 2))
.Value = Array("Datei Name", "Datei Pfad")
.Font.Bold = True
.Interior.PatternColorIndex = xlAutomatic
.Cells.Interior.ThemeColor = xlThemeColorAccent1
End With
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
End Sub
Private Sub OrdnerAuswählen()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & " \"
.Title = "Bitte Ordner wählen"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
sPfad = .SelectedItems(1)
End With
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
ReDim Preserve strList(0 To 1, lngCount)
strList(0, lngCount) = objFile.Name
strList(1, lngCount) = objFile.Path
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub