Blätter aller XLS-Dateien eines Verzeichnisses auf
24.07.2013 07:52:15
Rainer
Ich möchte gerne alle Excel-Dateinamen aus einem gestimmten Ordner in einer neuen Datei in Spalte A übertragen. Danach soll der erste Tabellenname in Splate B und der Wert aus C5 dieser Tabelle in Spalte C. Dieses Muster soll dann auf alle weiteren Tabellen so weiter fortgeführt werden. Also der Name der 2. Tabelle in Spalte D und deren Wert aus C5 dann in Spalte E.
Ich habe bereits einen guten Code gefunden. Deren Autor hat mich auf euch aufmerksam gemacht.
Ich danke euch schon jetzt für eure Bemühungen.
Sub DateienEinlesen()
'Listet alle Tabellenblätter aller Excel-Dateien auf
'12.07.2007, NoNet
Dim aktSh, wb, sh, Pfad, Dateityp, Datei, Zeile
Set aktSh = ActiveSheet
[A1] = "Dateiname"
[B1] = "Blattnamen"
Pfad = "C:\Temp\" 'Hier anpassen - unbedingt mit "\" am Ende !!
Dateityp = "*.xls" 'Hier anpassen
Datei = Dir(Pfad & Dateityp)
Application.DisplayAlerts = False 'Meldungen unterdrücken
Application.AskToUpdateLinks = False 'Verknüpfungsabfrage unterdrücken
Application.ScreenUpdating = False 'Bildschirmanzeige unterdrücken
Zeile = 1
While Datei ""
Zeile = Zeile + 1
Set wb = Workbooks.Open(Pfad & Datei)
aktSh.Cells(Zeile, 1) = Datei
Application.StatusBar = "Bearbeite " & Pfad & Datei
For Each sh In wb.Sheets 'Alle Blätter der Mappe durchlaufen
aktSh.Cells(Zeile, sh.Index + 1) = sh.Name
Next
wb.Close False 'Mappe schließen ohne Speichern
Datei = Dir() 'nächste Datei einlesen
Wend
Application.DisplayAlerts = True 'Meldungen wieder aktivieren
Application.AskToUpdateLinks = True 'Verknüpfungsabfrage wieder aktivieren
Application.ScreenUpdating = True 'Bildschirmanzeige wieder aktivieren
Application.StatusBar = False 'Statusleiste wieder auf STANDARD
Set aktSh = Nothing
Set wb = Nothing
Columns.AutoFit 'Spaltenbreite anpassen
MsgBox "Fertig !"
End
Sub
