Office 2013: Datum der zu importierenden Datei ermitteln

[volkswirt87]

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.

Code: Javascript

1. Option Explicit
2.  
3. Private strList() As String
4. Private lngCount As Long
5. Private sPfad As String
6.  
7. Public Sub DateienAuflisten()
8.  
9. Dim i As Long
10.  
11. With Application
12.     .ScreenUpdating = False
13.     .DisplayAlerts = False
14. End With
15.  
16. OrdnerAuswählen
17. lngCount = 0
18. SearchFiles sPfad, "*"
19.    
20. If lngCount = 0 Then
21.     MsgBox "Es wurde in der Ordnerstruktur" & sPfad & " keine Dateien gefunden!"
22.     Exit Sub
23. End If
24.    
25. With ThisWorkbook
26.     On Error Resume Next
27.     .Worksheets("Datei Übersicht").Delete
28.     On Error GoTo 0
29.     .Worksheets.Add(After:=Worksheets(ThisWorkbook.Worksheets.Count)).Name = "Datei Übersicht"
30. End With
31.  
32. With ActiveSheet
33.     .Range(.Cells(1, 1), .Cells(lngCount, 2)) = _
34.         WorksheetFunction.Transpose(strList)
35.     .Range(.Cells(1, 2), .Cells(lngCount, 2)).Replace What:=sPfad & "\", Replacement:="", _
36.        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
37.        SearchFormat:=False, ReplaceFormat:=False
38.    For i = 0 To lngCount - 1
39.        With .Cells(i + 1, 1)
40.        .Select
41.        .Cells(i + 1, 1).Hyperlinks.Add Anchor:=Selection, Address:=strList(1, i), TextToDisplay:=strList(0, i)
42.        End With
43.    Next i
44.    .Range("A:A").EntireColumn.AutoFit
45.    .Rows(1).Insert
46.    With Range(Cells(1, 1), Cells(1, 2))
47.        .Value = Array("Datei Name", "Datei Pfad")
48.        .Font.Bold = True
49.        .Interior.PatternColorIndex = xlAutomatic
50.        .Cells.Interior.ThemeColor = xlThemeColorAccent1
51.    End With
52. End With
53.  
54. With Application
55.    .ScreenUpdating = False
56.    .DisplayAlerts = False
57. End With
58.  
59. End Sub
60.  
61. Private Sub OrdnerAuswählen()
62.    
63. With Application.FileDialog(msoFileDialogFolderPicker)
64.    .InitialFileName = Application.DefaultFilePath & " \"
65.    .Title = "Bitte Ordner wählen"
66.    .Show
67.    If .SelectedItems.Count = 0 Then Exit Sub
68.        sPfad = .SelectedItems(1)
69. End With
70.  
71. End Sub
72.  
73. Private Sub SearchFiles(strFolder As String, strFileName As String)
74.    Dim objFolder As Object
75.    Dim objFile As Object
76.    Dim objFSO As Object
77.    Set objFSO = CreateObject("Scripting.FileSystemObject")
78.    For Each objFile In objFSO.GetFolder(strFolder).Files
79.        If objFile.Name Like strFileName Then
80.            ReDim Preserve strList(0 To 1, lngCount)
81.            strList(0, lngCount) = objFile.Name
82.            strList(1, lngCount) = objFile.Path
83.            lngCount = lngCount + 1
84.        End If
85.    Next
86.    For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
87.        SearchFiles strFolder & "\" & objFolder.Name, strFileName
88.    Next
89.  
90. End Sub
91.  

[maninweb]

Hallo,

musst das Array erweitern, siehe Beispiel hier:

Code: Visual Basic

1. Option Explicit
2.  
3. Private strList() As String
4. Private lngCount As Long
5. Private sPfad As String
6.  
7. Public Sub DateienAuflisten()
8.  
9. Dim i As Long
10.  
11. With Application
12.     .ScreenUpdating = False
13.     .DisplayAlerts = False
14. End With
15.  
16. OrdnerAuswählen
17. lngCount = 0
18. SearchFiles sPfad, "*"
19.    
20. If lngCount = 0 Then
21.     MsgBox "Es wurde in der Ordnerstruktur" & sPfad & " keine Dateien gefunden!"
22.     Exit Sub
23. End If
24.    
25. With ThisWorkbook
26.     On Error Resume Next
27.     .Worksheets("Datei Übersicht").Delete
28.     On Error GoTo 0
29.     .Worksheets.Add(After:=Worksheets(ThisWorkbook.Worksheets.Count)).Name = "Datei Übersicht"
30. End With
31.  
32. With ActiveSheet
33.     .Range(.Cells(1, 1), .Cells(lngCount, 4)) = _
34.         WorksheetFunction.Transpose(strList)
35.     .Range(.Cells(1, 2), .Cells(lngCount, 2)).Replace What:=sPfad & "\", Replacement:="", _
36.         LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
37.         SearchFormat:=False, ReplaceFormat:=False
38.     For i = 0 To lngCount - 1
39.         With .Cells(i + 1, 1)
40.         .Select
41.         .Cells(i + 1, 1).Hyperlinks.Add Anchor:=Selection, Address:=strList(1, i), TextToDisplay:=strList(0, i)
42.         End With
43.     Next i
44.     .Range("A:A").EntireColumn.AutoFit
45.     .Rows(1).Insert
46.     With Range(Cells(1, 1), Cells(1, 2))
47.         .Value = Array("Datei Name", "Datei Pfad")
48.         .Font.Bold = True
49.         .Interior.PatternColorIndex = xlAutomatic
50.         .Cells.Interior.ThemeColor = xlThemeColorAccent1
51.     End With
52. End With
53.  
54. With Application
55.     .ScreenUpdating = False
56.     .DisplayAlerts = False
57. End With
58.  
59. End Sub
60.  
61. Private Sub OrdnerAuswählen()
62.    
63. With Application.FileDialog(msoFileDialogFolderPicker)
64.     .InitialFileName = Application.DefaultFilePath & " \"
65.     .title = "Bitte Ordner wählen"
66.     .Show
67.     If .SelectedItems.Count = 0 Then Exit Sub
68.         sPfad = .SelectedItems(1)
69. End With
70.  
71. End Sub
72.  
73. Private Sub SearchFiles(strFolder As String, strFileName As String)
74.     Dim objFolder As Object
75.     Dim objFile As Object
76.     Dim objFSO As Object
77.     Set objFSO = CreateObject("Scripting.FileSystemObject")
78.     For Each objFile In objFSO.GetFolder(strFolder).Files
79.         If objFile.Name Like strFileName Then
80.             ReDim Preserve strList(0 To 3, lngCount)
81.             strList(0, lngCount) = objFile.Name
82.             strList(1, lngCount) = objFile.Path
83.             strList(2, lngCount) = objFile.DateCreated
84.             strList(3, lngCount) = objFile.DateLastModified
85.             lngCount = lngCount + 1
86.         End If
87.     Next
88.     For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
89.         SearchFiles strFolder & "\" & objFolder.Name, strFileName
90.     Next
91.  
92. End Sub
93.  

Gruß

[volkswirt87]

Ah, perfekt. Es hat funktioniert.
Besten Dank für die Unterstützung.