Arbeitsmappen listen Tabellen zeilenweise

Hallo Zusammen,
nachfolgender VBA-Code listet die Arbeitsmappen und deren Tabellen
aus einen Unterordner in Hauptverzeichnis aus. Und zwar Spaltenweise.
In Spalte A den Pfad, Spalte B Arbeitsmappe, und in Spalte C Tabellenname.
Nun hätte ich gerne, dass die Tabellennamen einer Arbeitsmappe nicht
untereinander in Spalte C gelistet werden sondern in einer Zeile
nebeneinander. Für jede Arbeitsmappe eine Zeile mit deren Tabellen.
Hier der Code:
Option Explicit
Dim wksInhalt As Worksheet, vntFiles(), lngFiles As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub DateiListe()
Dim FSO As Object, oFolder As Object
Dim strFolder As String
On Error GoTo FEHLER
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wksInhalt = ActiveSheet 'ThisWorkbook.Worksheets.Add
Set FSO = CreateObject("Scripting.FileSystemObject")
strFolder = ThisWorkbook.Path & "\Planung" 'GetDirectory
Set oFolder = FSO.getfolder(strFolder)
lngFiles = 1
With wksInhalt
.Cells.ClearContents
.Cells(1, 1) = "Ordner"
.Cells(1, 2) = "Name"
.Cells(1, 3) = "Tabellen"
.Range(.Cells(1, 1), .Cells(1, 3)).Font.Bold = True
End With
prcFiles oFolder
prcSubFolders oFolder
With wksInhalt
.Range(.Cells(2, 1), .Cells(lngFiles, UBound(vntFiles, 1))) = _
WorksheetFunction.Transpose(vntFiles)
.Activate
End With
FEHLER:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Private Sub prcSubFolders(oFolder)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.subfolders
prcFiles oSubFolder
prcSubFolders oSubFolder
Next
End Sub


Private Sub prcFiles(oFolder)
Dim oFile As Object, wkb As Workbook, wks As Worksheet
For Each oFile In oFolder.Files
If Right(oFile, 4) = ".xls" Then
Set wkb = Workbooks.Open(oFile, False, True)
For Each wks In wkb.Worksheets
ReDim Preserve vntFiles(1 To 3, 1 To lngFiles)
vntFiles(1, lngFiles) = oFolder
vntFiles(2, lngFiles) = oFile.Name
vntFiles(3, lngFiles) = wks.Name
lngFiles = lngFiles + 1
Next wks
wkb.Close False
End If
Next oFile
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
R = SHGetPathFromIDList(ByVal x, ByVal Path)
If R Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Kann mir jemand helfen?
Vielen Dank im Voraus.
Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Edie,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DateiListe()
Dim a
Dim result As Long, lngR As Long, intC As Integer
Dim objSh As Worksheet, objWB As Workbook
Dim objFSO As Object

On Error GoTo ErrExit
GMS

result = FileSearchFSO(a, ThisWorkbook.Path & "\Planung", "*.xls", True)

If result <> 0 Then

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    With ActiveSheet

        .UsedRange.ClearContents
        .Cells(1, 1) = "Ordner"
        .Cells(1, 2) = "Name"
        .Cells(1, 3) = "Tabellen..."
        .Rows(1).Font.Bold = True

        For lngR = 0 To UBound(a)

            .Cells(lngR + 2, 1) = objFSO.GetParentFolderName(a(lngR))
            .Cells(lngR + 2, 2) = objFSO.GetFileName(a(lngR))

            Set objWB = Workbooks.Open(a(lngR))

            For Each objSh In objWB.Worksheets
                .Cells(lngR + 2, 2 + objSh.Index) = objSh.Name
            Next

            objWB.Close False

        Next

        .Columns.AutoFit
    End With

End If

ErrExit:
GMS True
Set objWB = Nothing
Set objSh = Nothing
End Sub

Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.Getfolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    End If
Next

If SubFolders Then
    For Each mfsoSubFolder In mfsoFolder.SubFolders
        FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
    Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = lngCalc
    Else
        lngCalc = .Calculation
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Arbeitsmappen listen Tabellen zeilenweise

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