XL-Dateien und Tabellennamen auflisten
11.01.2013 15:48:07
NoNet
Hallo Sandra,
ich habe Deinen Code etwas modifiziert und ergänzt - jetzt werden die Dateinamen untereinander (in ein neues Blatt) aufgelistet und jeweils rechts daneben die enthaltenen Blätter.
Zum Auslesen der Tabellenblattnamen müssen die Dateien jedoch kurzzeitig geöffnet werden !
Bei meinen Daten funktioniert das Makro recht gut - Probleme könnte es allenfalls mit geschützten Mappen geben oder bei Mappen mit Workbook_Open() Makros !
Den Ordnernamen "C:\Temp\" musst Du zuvor natürlich anpassen ;-)
Option Explicit
'Makro zum Auflisten aller XL-Dateiene eines Verzeichnisses (ohne Unterverzeichnisse !)
'und Auflisten der darin enthaltenen Blätter (sofern nicht geschützt)
'11.01.2013, NoNet - www.excelei.de
Dim lngZ As Long
Sub GeschlosseneMappenListen()
Dim fs As Object
Dim fverz As Object
Dim fDatei As Object
Dim FDateien As Object
Dim strOrdner As String
Dim strTyp As String
lngZ = 1
strOrdner = "C:\Temp\" 'Ordnername mit "\" am Ende !
Set fs = CreateObject("Scripting.Filesystemobject")
Set fverz = fs.getfolder(strOrdner)
Set FDateien = fverz.Files
Application.EnableEvents = False 'keine Events ausführen !
Sheets.Add 'neues Blatt einfügen)
ActiveSheet.Name = "XL-Liste " & Format(Now, "YYYY-MM-DD hh-mm-ss")
[A1] = "Filename"
[B1] = "Sheets"
[C1] = "Sheet names"
For Each fDatei In FDateien
strTyp = Split(fDatei.Name, ".")(UBound(Split(fDatei.Name, ".")))
If UCase(strTyp) Like "XL*" And InStr(fDatei.Type, "Excel") > 0 Then
lngZ = lngZ + 1
Cells(lngZ, 1).Value = fDatei.Name
GetTabs (strOrdner & fDatei.Name)
End If
Next fDatei
Columns.AutoFit
Application.EnableEvents = True 'Events wieder ausführen !
MsgBox "Fertig !"
End Sub
Sub GetTabs(strDateiname)
Dim wsAkt As Worksheet, objXL, objWB, lngS As Long
Set wsAkt = ActiveSheet
Set objXL = GetObject(, "Excel.Application")
Set objWB = objXL.Workbooks.Open(Filename:=strDateiname, UpdateLinks:=False, ReadOnly:=True) _
wsAkt.Cells(lngZ, 2) = objWB.Sheets.Count
For lngS = 1 To objWB.Sheets.Count
wsAkt.Cells(lngZ, lngS + 2) = objWB.Sheets(lngS).Name
Next
Application.DisplayAlerts = False 'Keine Meldungen/Nachfragen beim Schließen anzeigen
objWB.Close
Set objWB = Nothing
Set objXL = Nothing
End Sub
Gruß, NoNet