Dateien öffnen - unterschiedliche Blatt Name
02.02.2007 10:12:01
Lilianna
ich habe ein Makro aus dem Archiv, das ich meinen Wünschen angepasst habe. Das klappt auch wunderschön, doch nun stellt sich eine weitere Herausforderung: Meine Blätter haben unterschiedliche Namen, aus denen die Daten herauskopiert werden sollen.
Die jetzigen .xls Dateien waren vorher .dat Dateien, d.h. die Mappe besteht nur aus einem Blatt, dass den Datei Name trägt.
Wo und wie muss ich den entsprechenden Code ändern?
Vielen Dank an alle, die Geduld mit Anfängern haben.
Sub DatenZusammenfuegen()
' Übernahme von Daten aus mehreren Blättern auf ein Tabellenblatt
Dim Blatt As Workbook, wb1 As Workbook, wks1 As Worksheet, Steuerung As Worksheet
Dim Pfad As String, Dateiname As String, wks2 As Worksheet, Reihe As Long
Dim Zeile1 As Long, Zeile As Long, Spalte As Integer
Set Steuerung = ThisWorkbook.Sheets("Tabelle1")
'Neue Arbeitsmappe anlegen
Set wb1 = Workbooks.Add
'Überzählige Blätter löschen
Application.DisplayAlerts = False
For i = wb1.Sheets.Count To 2 Step -1
wb1.Sheets(i).Delete
Next
Application.DisplayAlerts = True
Pfad = Steuerung.Range("B8").Value ' Verzeichnis der Blätter
Zeile1 = 3 '1. Zeile ab der Daten in neue Tabelle eingefügt werden sollen
Zeile = Zeile1
Set wks1 = wb1.Sheets(1)
Application.ScreenUpdating = False
Dateiname = Dir(Pfad & "\*.XLS")
Do Until Dateiname = ""
Set Blatt = Workbooks.Open(Pfad & "\" & Dateiname)
Application.StatusBar = "Datei " & Blatt.Name & " wird eingelesen"
' Daten im Blatt kopieren und in neues Blatt einfügen
Set wks2 = Blatt.Worksheets("Tabelle1")'hier muss wohl der neue Blattname hin
If Zeile = Zeile1 Then ' Spaltenbreiten formatieren bevor Daten aus 1. Blatt kopiert werden
For Spalte = 1 To 13 'Spalten A bis M
wks1.Cells(1, Spalte).ColumnWidth = wks2.Cells(1, Spalte).ColumnWidth
Next
End If
For Reihe = 1 To 2
If Application.WorksheetFunction.CountA(wks2.Range(wks2.Cells(Reihe, "A"), wks2.Cells(Reihe, "M"))) > 0 Then
wks2.Range(wks2.Cells(Reihe, "A"), wks2.Cells(Reihe, "M")).Copy wks1.Cells(Zeile, 1)
Zeile = Zeile + 1
End If
Next Reihe
Blatt.Close Savechanges:=False
Dateiname = Dir ' Nächste Datei
Loop
Application.StatusBar = False
Application.ScreenUpdating = False
'eventuell weitere Makros anhängen, je nach Bearbeitung
End Sub