AW: Hallo Franz, Hallo mari.......
04.02.2010 05:30:28
fcs
Hallo Volker,
es kann sein, das
Application.FileDialog(msoFolderPicker)
in VBA von Excel 2000 noch nicht integriert ist.
Hier eine Variante die über einen Dateiauswahldialog den Ordner ermittelt.
Die Datei wird nicht geöffnet, sondern "nur" der im Dialog gewählte Ordner ausgewertet.
Diese Methode funktioniert meines Wissens in allen älteren Excel-VBA-Versionen
Gruß
Franz
Sub Tabellenblattauslesen()
Dim sVerzeichnis$, sDatei$, StatusCalc As Long, ZeileZ As Long
Dim wbZiel As Workbook, wbQuelle As Workbook, oQuelle As Object, intI As Integer
Dim wksZiel As Worksheet
Dim sVerzAktuell As String, vAuswahl
On Error GoTo Fehler
'Suchverzeichnis auswahlen
StatusCalc = Application.Calculation
sVerzAktuell = VBA.CurDir 'Verzeichnis merken
vAuswahl = Application.GetOpenFilename(FileFilter:="Excel (*.xl*),*.xl*", _
Title:="Bitte im gewünschten Ordner eine Exceldatei wählen und Öffnen")
If vAuswahl False Then
sVerzeichnis = VBA.CurDir
sDatei = Dir(sVerzeichnis & Application.PathSeparator & "*.xl*")
If sDatei "" Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Do Until sDatei = ""
Application.StatusBar = "Bearbeite Datei " & sDatei
If LCase(sDatei) = LCase(ThisWorkbook.Name) Then
Set wbQuelle = ThisWorkbook
Else
Set wbQuelle = Workbooks.Open( _
Filename:=sVerzeichnis & Application.PathSeparator & sDatei, _
ReadOnly:=True)
End If
If wksZiel Is Nothing Then
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets(1)
ZeileZ = 1
With wksZiel
'Titelzeile ausfüllen
.Cells(ZeileZ, 3) = "Dateiname"
.Cells(ZeileZ, 4) = "Blatt-Nr"
.Cells(ZeileZ, 5) = "Blatt-Name"
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
End If
With wksZiel
intI = 0 'Blattzähler zurücksetzen
For Each oQuelle In wbQuelle.Sheets
intI = intI + 1
ZeileZ = ZeileZ + 1
.Cells(ZeileZ, 3) = sDatei
.Cells(ZeileZ, 4) = intI
.Cells(ZeileZ, 5) = oQuelle.Name
Next
End With
wbQuelle.Close savechanges:=False
Set wbQuelle = Nothing
NextDatei:
sDatei = Dir
Loop
Application.ScreenUpdating = True
End If
If wksZiel Is Nothing Then
MsgBox "Keine Excel-Dateien im Verzeichnis """ & sVerzeichnis _
& """ gefunden", vbInformation + vbOKOnly, _
"Arbeitsmappen-Tabellen-Liste"
Else
MsgBox "Alle Dateien im Verzeichnis """ & sVerzeichnis _
& """ ausgewertet", vbInformation + vbOKOnly, _
"Arbeitsmappen-Tabellen-Liste"
wksZiel.Columns.AutoFit
End If
End If
If VBA.CurDir sVerzAktuell Then VBA.ChDir sVerzAktuell
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Set wbZiel = Nothing: Set wksZiel = Nothing: Set wbQuelle = Nothing
Application.ScreenUpdating = True
If StatusCalc Application.Calculation Then Application.Calculation = StatusCalc
Application.EnableEvents = True
Application.StatusBar = False
End Sub