@Sepp: Brauch noch einmal Deine Hilfe!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit Private Sub Workbook_Open() Dim strPath As String, strFile As String Dim lngRow As Long strPath = "E:\Testdateien" strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\") strFile = Dir(strPath & "*", vbNormal) With Sheets("Test") .Columns(1).ClearContents Do While strFile <> "" lngRow = lngRow + 1 .Cells(lngRow, 1) = strFile strFile = Dir Loop End With Me.Save End Sub

Hallo,
bin zwar nicht Sepp..
Aus meinem Code-Keller:
In ein Modul:

Dim wksTest As Worksheet, vntFiles(), lngFiles As Long
Sub DateiListe()
Dim FSO As Object, oFolder As Object
Dim strFolder As String
Application.ScreenUpdating = False
Set wksTest = ThisWorkbook.Sheets("Test")
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Ordner wählen"
.AllowMultiSelect = False
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If strFolder = "" Then Exit Sub
Set oFolder = FSO.getfolder(strFolder)
lngFiles = 1
With wksTest
.Cells.ClearContents
.Cells(1, 1) = "Datei"
End With
prcFiles oFolder
prcSubFolders oFolder
With wksTest
.Range(.Cells(2, 1), .Cells(lngFiles, UBound(vntFiles, 1))) _
= WorksheetFunction.Transpose(vntFiles)
End With
ThisWorkbook.Save
Application.ScreenUpdating = True
End Sub
Sub prcSubFolders(oFolder)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.subfolders
prcFiles oSubFolder
prcSubFolders oSubFolder
Next
End Sub
Sub prcFiles(oFolder)
Dim oFile As Object
For Each oFile In oFolder.Files
ReDim Preserve vntFiles(1 To 1, 1 To lngFiles)
vntFiles(1, lngFiles) = oFile
lngFiles = lngFiles + 1
Next
End Sub

In DieseArbeitsmappe:

Private Sub Workbook_Open()
DateiListe
End Sub

Gruß
Rudi

Dim oDictF As Object Sub OrdnerListe() Dim FSO As Object, oFolder As Object Dim strFolder As String Application.ScreenUpdating = False Set FSO = CreateObject("Scripting.FileSystemObject") Set oDictF = CreateObject("Scripting.Dictionary") With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Ordner wählen" .AllowMultiSelect = False If .Show = -1 Then strFolder = .SelectedItems(1) End If End With If strFolder = "" Then Exit Sub Set oFolder = FSO.getfolder(strFolder) prcSubFolders oFolder With Sheets(1) .Cells.ClearContents .Cells(1, 1) = "Ordner" .Cells(2, 1).Resize(oDictF.Count) = WorksheetFunction.Transpose(oDictF.keys) .Columns(1).AutoFit .Activate End With Application.ScreenUpdating = True End Sub Sub prcSubFolders(oFolder) Dim oSubFolder As Object For Each oSubFolder In oFolder.subfolders oDictF(oFolder) = 0 prcSubFolders oSubFolder Next End Sub

Beliebteste Forumthreads (12 Monate)

@Sepp: Brauch noch einmal Deine Hilfe!

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread