Hallo, wie kann ich aus 200 Excel Dateien mit fortlaufendem Namen (Book1 bis Book200) eine einzige Tabelle erstellen? Die in den einzelnen Dateien enthaltenen Tabellen sind sehr klein, zwischen 2 und 7 Zeilen, jeweils 4 Spalten.
Immer das gleiche Schema, jede Tabelle beginnt mit dem Begriff #item
Die Lösung kann für Excel 2007/2010 oder eben OpenOffice/LibreOffice Calc gelten.
Beim Importieren in Libre Office über „Einfügen aus Datei“ wird jede Datei zu einer neuen, eigenständigen Tabelle, ich möchte aus allen Daten eine Tabelle machen.
Vielen Dank schon mal.
Hallo Sovielefragen,
hier ein entsprechendes Makro erstellt unter Excel 2007.
Gruß
Franz
Sub DateienZusammenfuehren()
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim wbQuelle As Workbook, wksQuelle As Worksheet, iCount As Integer
Dim strSep As String, strDatei As String, strVerz As String
Dim lngZeile\_Z As Long
Dim StatusCalc As Long
On Error GoTo Fehler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis wählen mit den Dateien, die zusammengeführt werden sollen"
If .Show = -1 Then
strSep = Application.PathSeparator
strVerz = .SelectedItems(1)
strDatei = Dir(strVerz & strSep & "Book\*.xls\*") 'Datei-Suchstring ggf. anpassen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Do Until strDatei = ""
If wbZiel Is Nothing Then
'leere Mappe anlegen, in die Daten kopiert werden.
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksZiel = wbZiel.Worksheets(1)
lngZeile\_Z = 1
Else
With wksZiel
lngZeile\_Z = .Cells.SpecialCells(xlCellTypeLastCell).Row + 1
End With
End If
Set wbQuelle = Workbooks.Open(Filename:=strVerz & strSep & strDatei, \_
ReadOnly:=False)
Set wksQuelle = wbQuelle.Worksheets(1)
iCount = iCount + 1
Application.StatusBar = "Bearbeite Datei Nummer " & iCount & " - " & wbQuelle.Name
With wksQuelle
.Range(.Cells(1, 1), .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row, 4)).Copy \_
Destination:=wksZiel.Cells(lngZeile\_Z, 1) 'Spalte des zu kopierenden Bereichs \_
ggf. anpassen
End With
NextDatei:
wbQuelle.Close savechanges:=False
Set wbQuelle = Nothing
Set wksQuelle = Nothing
strDatei = Dir
Loop
Application.StatusBar = False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
MsgBox "Fertig"
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case 111
Case Else
If MsgBox(Prompt:="Fehler-Nr.: " & .Number & vbLf \_
& .Description, Buttons:=vbRetryCancel, Title:="Fehlermeldung") = vbRetry Then
Resume NextDatei
Else
If Not wbQuelle Is Nothing Then
wbQuelle.Close savechanges:=False
End If
End If
End Select
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
Set wbQuelle = Nothing: Set wksQuelle = Nothing
Set wbZiel = Nothing: Set wksZiel = Nothing
End Sub