AW: Dateien mit Worksheets auflisten
31.08.2009 16:09:08
JogyB
Hi.
Noch eine Variante nur mit Dateinamen (ist wie bei fcs), listet allerdings noch den Pfad in D1 auf (ist ja für alle Dateien derselbe). Außerdem hatte ich vergessen, das ScreenUpdating wieder zu aktivieren.
Sub list_Worksheets()
Dim daTeien
Dim myDatei
Dim schrZeile As Long
Dim i As Long
Dim quellWbk As Workbook
Dim zielWbk As Workbook
Application.ScreenUpdating = False
daTeien = Application.GetOpenFilename("Excel Dateien (*.xls), *.xls", , "Dateien auswählen", _
, True)
' Wenn kein Array, dann wurde nichts ausgewählt
If Not IsArray(daTeien) Then
Application.ScreenUpdating = True
Exit Sub
End If
' Übersichtsdatei erzeugen
Set zielWbk = Workbooks.Add
For i = zielWbk.Worksheets.Count To 2 Step -1
Application.DisplayAlerts = False
zielWbk.Worksheets(i).Delete
Application.DisplayAlerts = True
Next
With zielWbk.Sheets(1)
.name = "Übersicht"
.Cells(1, 1).Value = "Dateiname"
.Cells(1, 2).Value = "Arbeitsblätter"
.Cells(1, 1).Font.Bold = True
.Cells(1, 2).Font.Bold = True
' Pfad eintragen
.Cells(1, 3).Value = "Pfad:"
.Cells(1, 4).Value = Left(daTeien(1), InStrRev(daTeien(1), "\"))
.Cells(1, 3).Font.Bold = True
.Cells(1, 3).HorizontalAlignment = xlRight
schrZeile = 2
' Events, Alerts und Berechnung aus, sind hier uninteressant
' Einfach zur Sicherheit, damit garantiert nichts ausgeführt wird
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
' Geht alle Dateien durch und liest die Worksheets aus
' Kann die Datei nicht geöffnet werden, wird ein Fehler in Spalte B geschrieben
For Each myDatei In daTeien
On Error Resume Next
Set quellWbk = Workbooks.Open(myDatei, False, True)
On Error GoTo 0
If quellWbk Is Nothing Then
.Cells(schrZeile, 1) = Mid(myDatei, InStrRev(myDatei, "\") + 1)
.Cells(schrZeile, 2) = "Datei konnte nicht geöffnet werden."
schrZeile = schrZeile + 2
Else
.Cells(schrZeile, 1) = quellWbk.name
For i = 1 To quellWbk.Worksheets.Count
.Cells(schrZeile + i - 1, 2).Value = quellWbk.Worksheets(i).name
Next
' i steht auf Worksheets.Count + 1, damit ergibt sich bei Addition von i die _
gewünschte Leerzeile
schrZeile = schrZeile + i
quellWbk.Close False
End If
Set quellWbk = Nothing
Next
' Alles wieder an
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
.Cells(1, 1).EntireColumn.AutoFit
.Cells(1, 2).EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Gruss, Jogy