AW: Zusammenführung von Dateien
19.08.2014 10:48:02
Dateien
Hallo Steffen,
im Moment wird ja immer das komplette Tabellenblatt nach der Umwandlung von Formeln in Werte von der Quelldatei in die Zieldatei kopiert. Das hat den Vorteil, dass man sich nicht um Formatierungen und Seitenlayout des Tabellenblatts kümmern. Probleme gibt es "nur", wenn die Quelldateien alte (2003 und älter) und neue (2007 und jünger) Dateiformate beinhalten.
Grundsätzlich gäbe es jetzt 2 Varianten:
A) Nach dem Kopieren des Blattes in die Zieldatei werden die nicht benötigten Spalten und Zeilen gelöscht.
B) Aus der Tabelle der 1. Quelldatei wird eine Mustertabelle generiert.
Bei den weiteren Quelldateien wird dann jeweils die Mustertabelle kopiert und der gewünschte Quelldatenbereich hineinkopiert.
Nachfolgended findest du das ursprüngliche Makro angepasst für beide Varianten.
Hier musst du die Zeilen-/Spaltenbereiche und den zu kopierenden Bereich anpassen.
Gruß
Franz
'Variante A
Sub Tabelle1_Holen_aus_Dateien_A()
'1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe zusammenkopieren
'und nicht gewünschte Daten löschen
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim varVerzeichnis As Variant
Dim wkbQuelle As Workbook, wksQuelle As Worksheet
Dim strDatei As String, intK As Integer
Dim Zeile_L As Long, Spalte_L As Long
On Error GoTo Fehler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die " _
& "zusammengefasst werden sollen"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
strDatei = Dir(varVerzeichnis & "\*.xls*")
If strDatei = "" Then
MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
Exit Sub
End If
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do Until strDatei = ""
'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
If LCase(strDatei) LCase(ThisWorkbook.Name) Then
intK = intK + 1
Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
Set wkbQuelle = Application.Workbooks.Open( _
Filename:=varVerzeichnis & "\" & strDatei, _
ReadOnly:=True, UpdateLinks:=False)
Set wksQuelle = wkbQuelle.Worksheets(1)
wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn formeln vorhanden sind
'wenn keine Formeln kopiert werden sollen
With wksQuelle.UsedRange
.Value = .Value
End With
'Blatt in neue Mappe kopieren
If wkbZiel Is Nothing Then
wksQuelle.Copy
Set wkbZiel = ActiveWorkbook
Else
wksQuelle.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
End If
'kopiertes Blatt umbenennen
Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
With wksZiel
.Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1
'Überzälige Zeilen löschen - von unten her
'- Zeilen am Ende der Liste
If Zeile_L > 120 Then
.Range(.Rows(121), .Rows(Zeile_L)).Delete
End If
'- Zeilen am Anfang der Liste
.Range(.Rows(1), .Rows(22)).Delete
'Überzälige Spalten löschen - rechts kommend
'- Spalten rechts in Liste
If Spalte_L > 26 Then
.Range(.Columns(27), .Columns(Spalte_L)).Delete
End If
'- Spalten links in Liste
'nicht zutreffend
End With
'Quelldatei ohne speichern wieder schließen
wkbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wkbQuelle = Nothing
End If
'nächste Datei suchen
strDatei = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Select
End With
Beenden:
End Sub
'Variante B
Sub Tabelle1_Holen_aus_Dateien_B()
'Daten aus 1. Tabellenblatt aus allen Exceldateien eines Verzeichnisses in eine Mappe _
zusammenkopieren
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim varVerzeichnis As Variant
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, wksMuster As Worksheet
Dim strDatei As String, intK As Integer
Dim Zeile_L As Long, Spalte_L As Long
On Error GoTo Fehler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Excel-Dateien auswählen, die " _
& "zusammengefasst werden sollen"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
strDatei = Dir(varVerzeichnis & "\*.xls*")
If strDatei = "" Then
MsgBox "Keine Excel-Dateien im gewählten Verzeichnis"
Exit Sub
End If
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Do Until strDatei = ""
'Quelldatei schreibgeschütz öffnen, keine Links aktualisieren
If LCase(strDatei) LCase(ThisWorkbook.Name) Then
intK = intK + 1
Application.StatusBar = intK & ". Datei wird importiert: " & strDatei
Set wkbQuelle = Application.Workbooks.Open( _
Filename:=varVerzeichnis & "\" & strDatei, _
ReadOnly:=True, UpdateLinks:=False)
Set wksQuelle = wkbQuelle.Worksheets(1)
wksQuelle.Calculate 'Quelltabelle neu berechnen, wenn formeln vorhanden sind
'wenn keine Formeln kopiert werden sollen
With wksQuelle.UsedRange
.Value = .Value
End With
'Blatt in neue Mappe kopieren
If wkbZiel Is Nothing Then
wksQuelle.Copy
Set wkbZiel = ActiveWorkbook
Set wksMuster = wkbZiel.Worksheets(1)
With wksMuster
.Name = "Musterblatt"
'Musterblatt aufbereiten
'Inhalte im Zieldatenbereich löschen
.Range("A23:Z120").ClearContents
'letzte Zeile und Spalte ermitteln
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1
'Überzälige Zeilen löschen - von unten her
'- Zeilen am Ende der Liste
If Zeile_L > 120 Then
.Range(.Rows(121), .Rows(Zeile_L)).Delete
End If
'- Zeilen am Anfang der Liste
.Range(.Rows(1), .Rows(22)).Delete
'Überzälige Spalten löschen - rechts kommend
'- Spalten rechts in Liste
If Spalte_L > 26 Then
.Range(.Columns(27), .Columns(Spalte_L)).Delete
End If
'- Spalten links in Liste
'nicht zutreffend
Application.ScreenUpdating = True
.Range("A1").Select
Application.ScreenUpdating = False
End With
End If
'Musterblatt kopieren
wksMuster.Copy after:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
'kopiertes Blatt umbenennen
Set wksZiel = wkbZiel.Sheets(wkbZiel.Sheets.Count)
With wksZiel
.Name = Left(strDatei, InStrRev(strDatei, ".") - 1)
wksQuelle.Range("A23:Z120").Copy Destination:=.Cells(1, 1)
End With
'Quelldatei ohne speichern wieder schließen
wkbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wkbQuelle = Nothing
End If
'nächste Datei suchen
strDatei = Dir
Loop
'Musterblatt wieder löschen
Application.DisplayAlerts = False
wksMuster.Delete
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Fertig, " & intK & " Dateien eingelesen"
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbQuelle Is Nothing Then wkbQuelle.Close savechanges:=False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Select
End With
Beenden:
End Sub