AW: Namen von Tabellenblättern aus Dateien auslese
28.07.2006 21:03:38
Tabellenblättern
Hallo Erich,
hier das Makro mit den Anpassungen. Statt wbNeu gibt es jetzt das Objekt wksNamen, dem die Tabelle "gefunden2" zugewiesen wird
Da die Daten jetzt immer in das gleiche Blatt geschrieben werden hab ich einen 3-Zeiler zum Löschen der Altdaten eingefügt, ggf wieder löschen.
Alle datendateien werden jetzt schreibgeschützt geöffent, so das versehentliche überschreiben auch nicht mehr passieren kann.
Gruß
Franz
Sub Tabellenblaetter()
'Listet aus Dateien die Tabelleblätter abhängig von Bedingungen
Dim wb As Workbook, wks As Worksheet, wksNamen As Worksheet
Dim arrDateien, Pfad As String, i As Integer, j As Integer
Dim NoNameVor As Boolean, SpwbName As Integer, SpwksName As Integer
Pfad = "c:\Test" 'Verzeichnis der Dateien
'Namen der Dateien
arrDateien = Array("Datei1.xls", "Datei2.xls", "Datei3.xls", "Datei4.xls")
NameVor = "Beginn" 'Name des Registers nach dem Tabellennamen ausgelesen werden sollen
NameNach = "Ende" 'Name des Registers bis vor dem Tabellennamen ausgelesen werden sollen
Set wksNamen = ThisWorkbook.Sheets("gefunden2") 'Blatt in dem die Namen eingetragen werden
'Spaltentitel eintragen
SpwbName = 1 ' Spalte in der Dateiname eingetragen wird
SpwksName = 2 ' Spalte in der Tabellenname eingetragen wird
wksNamen.Cells(1, SpwbName) = "Dateiname" 'ggf. ändern/löschen
wksNamen.Cells(1, SpwksName) = "Tabellenname" 'ggf. ändern/löschen
Zeile = 2 'Zeile ab der die Daten im Tabelenblatt eingetragen werden sollen
' Altdaten löschen, Passage entfernen, falls nicht erforderlich
With wksNamen
.Range(.Cells(Zeile, SpwbName), .Cells(.Rows.Count, SpwksName).End(xlUp)).ClearContents
End With
'Dateien abarbeiten
For i = 0 To UBound(arrDateien)
Application.ScreenUpdating = False
Set wb = Workbooks.Open(FileName:=Pfad & "\" & arrDateien(i), ReadOnly:=True)
With wb
j = 1
' Blätter einschließlich Blatt Beginn überspringen
Do Until .Sheets(j).Name = NameVor
If j = .Sheets.Count Then
NoNameVor = True
MsgBox "In Datei '" & arrDateien(i) & "' wurde die Tabelle '" & NameVor & "' nicht gefunden."
Exit Do
End If
j = j + 1
Loop
' Blätter bis Blatt Ende auswerten und in Liste eintragen
' Falls Blatt Beginn fehlt werden keine weiteren Blattnamen ausgelesen
' Falls Blatt Ende fehlt werden alle weiteren Blätter ausgewertet
Do Until NoNameVor = True
j = j + 1
Set wks = .Sheets(j)
With wks
If .Name = NameNach Then Exit Do
'MsgBox "Summe D4:D5 in Tabelle " & .Name & ": " & .Range("D4") + .Range("D5") ' Testzeile
If .Range("D4") + .Range("D5") > 1 Then
wksNamen.Cells(Zeile, SpwbName) = wb.Name
wksNamen.Cells(Zeile, SpwksName) = wks.Name
Zeile = Zeile + 1
End If
End With
If j = .Sheets.Count Then
MsgBox "In Datei '" & arrDateien(i) & "' wurde die Tabelle '" & NameNach & "' nicht gefunden."
Exit Do
End If
Loop
NoNameVor = False
'Datei wieder schließen
.Close
End With
Application.ScreenUpdating = True
Next i
End Sub