Office: (Office 2007) mehrere Dateien mittels Makro zusammenführen (summieren)

Hallo zusammen!

Ich habe folgendes Problem und hoffe ihr könnt mir helfen:

Ich habe mehrere Tabellen (jeweils eine einzelne Datei, keine Tabellenblätter innerhalb einer Arbeitsmappe) die alle gleich aufgebaut sind. Es handelt sich hierbei um die Kostenauflistung verschiedener Abteilungen, jede wie gesagt in einer separaten Excel-Datei. In der Spalte A befinden sich diverse Kostenarten und in der ersten Zeile sind diese von Januar bis Dezember aufgeschlüsselt. (alles immer im ersten Tabellenblatt einer jeden Datei) Ziel ist es, die Werte aller Dateien in eine neue Datei (Gesamtübersicht) zu übertragen. Dabei sollen die Werte aber nicht wie öfters einfach hintereinander oder untereinander kopiert werden, sondern sie sollen alle summiert werden. Hintergrund ist, dass eine Gesamtdarstellung aller Kosten über sämtliche Abteilungen benötigt wird.
Optimal wäre es, wenn Excel alle Dateien in dem angegeben Verzeichnis automatisch öffnet, dann die Zeilen- und Spalten-Beschriftung einer beliebigen Datei (sie sind ja alle gleich aufgebaut) für die Gesamtdarstellung übernimmt und dann natürlich am wichtigsten, die eingetragenen Werte aller Dateien in die Gesamtdarstellung summiert.

Ich habe bereits versucht das Problem zu lösen, indem ich Excel einen Makro habe aufzeichnen lassen, jedoch kommt bei einem anschließenden Versuch immer ein Laufzeitfehler.

Damit man sich besser vorstellen kann, wie es letztlich aussehen soll, habe ich versucht es im Anhang darzustellen.


Vielen Dank für eure Hilfe im Voraus!!
Viele Grüße!

:)

 

Hallo ???,

Schau mal hier rein:

http://www.ms-office-forum.net/forum...8&postcount=15

von:
' Mehrere schreibgeschütze xls-Dateien öffnen und Werte in die Zusammenfassung eintragen
' erstellt am 15.07.2010 von MS-OFFICE-Forum / Backowe
' abgespeichert von zra am 15.07.2010
' abgeändert am 19.01.2011 von MS-OFFICE-Forum / EarlFred
' abgespeichert von zra am 19.01.2011

Option Explicit

Sub OpenFiles()

bis:

Sub EreignisseEin()
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

mfg
Roland

 

Hallo Marcel,

kopiere den folgenden Code in ein allgemeines Modul, passe den Pfad zu den Dateien an und probiere mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfassung()
Dim objWB As Workbook, objWB2 As Workbook, objSh As Worksheet
Dim rng As Range, rngConst As Range
Dim strPath As String, strFile As String
Dim bolFirst As Boolean

Dim lngCalc As Long

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

strPath = "E:\Forum\Test2" 'Pfad zu den Dateien - Anpassen

strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

strFile = Dir(strPath & "*.xls*", vbNormal)

bolFirst = True

Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
If bolFirst Then
Set objWB = Workbooks.Open(strPath & strFile)
Set rngConst = objWB.Sheets(1).UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
bolFirst = False
Else
Set objWB2 = Workbooks.Open(strPath & strFile)
For Each rng In rngConst
rng = rng + objWB2.Sheets(1).Range(rng.Address)
Next
objWB2.Close False
End If
End If
strFile = Dir
Loop

objWB.SaveAs ThisWorkbook.Path & "\Zusammenfassung_" & Format(Date, "yyyymmdd") & "." & Split(objWB.Name, ".")(1), FileFormat:=objWB.FileFormat

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With

Set objWB = Nothing
Set objWB2 = Nothing
Set rng = Nothing
Set rngConst = Nothing
End Sub





« Gruß Sepp »

 

Hallo Josef!

Zuerst einmal vielen Dank für die schnelle Hilfe!!

Ich fange mal mit der guten Nachricht an *Smilie der Makro arbeitet soweit ohne Fehlermeldungen und erzeugt eine Datei Zusammenfassung.
Bei der Testdatei, die ich auch hochgeladen hatte, funktioniert das einwandfrei und sie Summe über alle Einzeldateien stimmt.

Jedoch tritt bei den richtigen Dateien ein Problem auf:

Wenn ich diese zusammenfassen möchte, werden zwar alle Dateien nacheinander geöffnet, es werden aber nur die Werte aus der ersten berücksichtigt.
Ich glaube dieses Problem rührt daher, dass die Zahlen des ersten Arbeitsblattes, einer jeden Datei, durch Formeln mit anderen Arbeitsblättern derselben Datei verknüpft sind.
Damit man es sich besser vorstellen kann, habe ich noch einmal 3 Dateien hochgeladen, die ersten beiden sind die Ausgangsdateien, die dritte ist die durch den Makro erstellte Zusammenfassung.
Wie du siehst werden die Werte, die lediglich als Zahlen eingegeben wurden, perfekt summiert. Allerdings bei den Reisekosten, welche in einem anderen Tabellenblatt berechnet und dann nach vorne verknüpft werden, werden nur die Werte der ersten Datei übernommen, weswegen die Endsumme natürlich nicht mehr stimmt.
Da bei den Dateien mit denen ich letztlich arbeite praktisch alle Werte durch Verknüpfungen aus anderen Tabellenblättern geholt werden, erklärt sich das Ergebnis, dass scheinbar nur erste Datei berücksichtigt wurde.

Ich muss mich hier entschuldigen, dass ich nicht gleich eine Datei mit mehreren Tabellenblättern und entsprechenden Verknüpfungen hochgeladen habe, ich hatte nicht erwartet, dass dies irgendwelche Auswirkungen haben könnte.

Das letzte „Problem“ was mir aufgefallen ist, dass bei der Zusammenfassung immer alle anderen Tabellenblätter der ersten Datei mit kopiert werden. Es ist wie schon angedeutet nur das erste nötig, aber vielleicht hängt dies ebenfalls wieder mit den Verknüpfungen zusammen.

Vielleicht könntest du mir noch einmal helfen. Abgesehen von dem Fehler bei den Verknüpfungen, funktioniert der Makro super.

Viele Grüße!

 

Hallo Marcel,

ok, dann ein neuer Versuch;-))

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfassung()
Dim objWB As Workbook, objSh As Worksheet
Dim rng As Range, rngConst As Range
Dim strPath As String, strFile As String, strExt As String
Dim bolFirst As Boolean
Dim lngCalc As Long, lngFormat As Long

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

strPath = "E:\Forum\Test2" 'Pfad zu den Dateien - Anpassen

strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

strFile = Dir(strPath & "*.xls*", vbNormal)

bolFirst = True

Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
If bolFirst Then
Set objWB = Workbooks.Open(strPath & strFile)
objWB.Sheets(1).Copy
Set objSh = ActiveSheet
objSh.UsedRange = objSh.UsedRange.Value
objWB.Close False
Set rngConst = objSh.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
bolFirst = False
Else
Set objWB = Workbooks.Open(strPath & strFile)
For Each rng In rngConst
rng = rng + objWB.Sheets(1).Range(rng.Address)
Next
objWB.Close False
End If
End If
strFile = Dir
Loop

getFileExtAndFormat objSh.Parent, strExt, lngFormat
objSh.Parent.SaveAs ThisWorkbook.Path & "\Zusammenfassung_" & Format(Date, "yyyymmdd") & strExt, FileFormat:=lngFormat

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With

Set objWB = Nothing
Set objSh = Nothing
Set rng = Nothing
Set rngConst = Nothing
End Sub

Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
With WB
If Val(Application.Version) < 12 Then
strExt = ".xls": lngFormat = -4143
Else
Select Case WB.FileFormat
Case 51: strExt = ".xlsx": lngFormat = 51
Case 52:
If .HasVBProject Then
strExt = ".xlsm": lngFormat = 52
Else
strExt = ".xlsx": lngFormat = 51
End If
Case 56: strExt = ".xls": lngFormat = 56
Case Else: strExt = ".xlsb": lngFormat = 50
End Select
End If
End With
End Function





« Gruß Sepp »

 

Hi Josef!

Vielen lieben Dank für deine Hilfe! Jetzt funkioniert es perfekt! Bin sprachlos! Wie gesagt, hab vielen Dank!

Wenn ich darf würde ich dir gerne noch eine letzte Frage stellen:

Ist es möglich den Bereich der je vom ersten Tabellenblatt aller Dateien kopiert und anschließend in der Zusammenfassung summiert wird zu begrenzen?
Im Moment wird ja durch das "UsedRange" der gesamte beschriebene Bereich genommen.
In den Dateien mit denen ich arbeite befinden sich unter den wichtigen Zeilen noch diverse andere Formeln und Eintragungen, die nicht weiter relevant sind. Darum würde ich gerne den Bereich auf A1:R120 begrenzen. Ich habe bereits versucht das in folgender Zeile zu ändern und den markeiten Bereich durch Range("A1:R120") einzuschränken, jedoch brachte dies eine Fehlermeldung.

Do While strFile ""
If strFile ThisWorkbook.Name Then
If bolFirst Then
Set objWB = Workbooks.Open(strPath & strFile)
objWB.Sheets(1).Copy
Set objSh = ActiveSheet
objSh.UsedRange = objSh.UsedRange.Value objWB.Close False
Set rngConst = objSh.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
bolFirst = False

Wenn dies zu viel Arbeit macht, ist das absolut kein Problem und ich füge am Ende einfach eine Zeile an, um den überflüssigen Bereich zu löschen. Aber vielleicht gibt es auch eine elegantere Lösung um den Bereich mit dem gearbeitet werden soll, einfach vorzugeben?

Viele Grüße

 

Hallo Marcel,

ersetze diesen Teil.

Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
If bolFirst Then
Set objWB = Workbooks.Open(strPath & strFile)
objWB.Sheets(1).Copy
Set objSh = ActiveSheet
With objSh
.Range("A1:R120") = .Range("A1:R120").Value
.Range("A121:A" & .Rows.Count).EntireRow.Delete
Set rngConst = .Range("A1:R120").SpecialCells(xlCellTypeConstants, xlNumbers)
End With
objWB.Close False
bolFirst = False
Else
Set objWB = Workbooks.Open(strPath & strFile)
For Each rng In rngConst
rng = rng + objWB.Sheets(1).Range(rng.Address)
Next
objWB.Close False
End If
End If
strFile = Dir
Loop



« Gruß Sepp »

 

Noch einmal vielen Dank Josef, dass du dir die Zeit für mein Problem genommen hast! Einfach klasse!

Ich wünsche dir noch einen schönen Abend!
Lass es dir gut gehen!

Viele Grüße Marcel

 

Hallo Josef,

du warst so freundlich und hattest mir vor ein paar Wochen bei einer VBA-Geschichte geholfen, in der es darum ging, mehrere Dateien mittels Makro zusammenführen und zu summieren.
Der Code den du mir geschrieben hattest funktioniert perfekt, an dieser Stelle noch einmal vielen Dank für deine Mühe!!
Inzwischen hat es sich ergeben, dass neben dem Tabellenblatt 1 auch das Tabellenblatt 2 auf dieselbe Weise zusammengeführt werden soll. Auch die Bereiche sind identisch von A1:R120.
Da du so nett warst und mir ja schon einmal geholfen hast, wollte ich dich fragen, ob du mir vielleicht noch einmal helfen könntest? Wie gesagt es bleibt alles so wie beim letzten Fall, nur das diesmal die Tabellenblätter 1 und 2 aller Dateien zusammengeführt werden sollen.
Ich habe dir noch einmal den Code von dir und 3 Dateien zum besseren Verständnis drangehangen.

Viele Grüße
Marcel


Option Explicit

Sub zusammenfassung()
Dim objWB As Workbook, objSh As Worksheet
Dim rng As Range, rngConst As Range
Dim strPath As String, strFile As String, strExt As String
Dim bolFirst As Boolean
Dim lngCalc As Long, lngFormat As Long

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

strPath = "....................." 'Pfad zu den Dateien - Anpassen

strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

strFile = Dir(strPath & "*.xls*", vbNormal)

bolFirst = True

Do While strFile ""
If strFile ThisWorkbook.Name Then
If bolFirst Then
Set objWB = Workbooks.Open(strPath & strFile)
objWB.Sheets(1).Copy
Set objSh = ActiveSheet
With objSh
.Range("A1:R120") = .Range("A1:R120").Value
.Range("A121:A" & .Rows.Count).EntireRow.Delete
Set rngConst = .Range("A1:R120").SpecialCells(xlCellTypeConstants, xlNumbers)
End With
objWB.Close False
bolFirst = False
Else
Set objWB = Workbooks.Open(strPath & strFile)
For Each rng In rngConst
rng = rng + objWB.Sheets(1).Range(rng.Address)
Next
objWB.Close False
End If
End If
strFile = Dir
Loop

' abspeichern

getFileExtAndFormat objSh.Parent, strExt, lngFormat
objSh.Parent.SaveAs ThisWorkbook.Path & "\LIST_" & Format(Date, "yymmdd") & "_Zusammenfuehrung" & strExt, FileFormat:=lngFormat

ErrExit:

With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With

Set objWB = Nothing
Set objSh = Nothing
Set rng = Nothing
Set rngConst = Nothing

End Sub

Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
With WB
If Val(Application.Version) < 12 Then
strExt = ".xls": lngFormat = -4143
Else
Select Case WB.FileFormat
Case 51: strExt = ".xlsx": lngFormat = 51
Case 52:
If .HasVBProject Then
strExt = ".xlsm": lngFormat = 52
Else
strExt = ".xlsx": lngFormat = 51
End If
Case 56: strExt = ".xls": lngFormat = 56
Case Else: strExt = ".xlsb": lngFormat = 50
End Select
End If
End With
End Function

 

Hallo Marcel,

teste mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfassung()
Dim objWB As Workbook, objNew As Workbook, objSh As Worksheet
Dim rng As Range, rngConst(1 To 2) As Range
Dim strPath As String, strFile As String, strExt As String
Dim bolFirst As Boolean
Dim lngCalc As Long, lngFormat As Long, lngIndex As Long

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

strPath = "E:\Forum\Test" 'Pfad zu den Dateien - Anpassen

strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

strFile = Dir(strPath & "*.xls*", vbNormal)

bolFirst = True

Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
If bolFirst Then
Set objWB = Workbooks.Open(strPath & strFile)
objWB.Sheets(Array(1, 2)).Copy
Set objNew = ActiveWorkbook
For Each objSh In objNew.Worksheets
With objSh
.Range("A1:R120") = .Range("A1:R120").Value
.Range("A121:A" & .Rows.Count).EntireRow.Delete
Set rngConst(.Index) = .Range("A1:R120").SpecialCells(xlCellTypeConstants, xlNumbers)
End With
Next
objWB.Close False
bolFirst = False
Else
Set objWB = Workbooks.Open(strPath & strFile)
For lngIndex = 1 To UBound(rngConst)
For Each rng In rngConst(lngIndex)
rng = rng + objWB.Sheets(lngIndex).Range(rng.Address)
Next
Next
objWB.Close False
End If
End If
strFile = Dir
Loop

' abspeichern

getFileExtAndFormat objNew, strExt, lngFormat
objNew.SaveAs ThisWorkbook.Path & "\LIST_" & Format(Date, "yymmdd") & "_Zusammenfuehrung" & strExt, FileFormat:=lngFormat

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With

Set objWB = Nothing
Set objNew = Nothing
Set objSh = Nothing
Set rng = Nothing
Erase rngConst
End Sub

Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
With WB
If Val(Application.Version) < 12 Then
strExt = ".xls": lngFormat = -4143
Else
Select Case WB.FileFormat
Case 51: strExt = ".xlsx": lngFormat = 51
Case 52:
If .HasVBProject Then
strExt = ".xlsm": lngFormat = 52
Else
strExt = ".xlsx": lngFormat = 51
End If
Case 56: strExt = ".xls": lngFormat = 56
Case Else: strExt = ".xlsb": lngFormat = 50
End Select
End If
End With
End Function





« Gruß Sepp »

 

Ich kann dir gar nicht oft genug danken Josef!! Einfach klasse, funktioniert auf Anhieb einwandfrei! Bist echt genial!

Hab vielen Dank noch mal!

Grüße Marcel

 

Hallo,

ich kann diesen Quellcode sehr gut bei mir anwenden.
Allerdings habe ich drei Tabellenblätter zu konsolidieren (und nicht wie hier 2).

Welche Änderungen muss ich durchführen, damit es mit drei Blättern funktionert?

Habe schon einiges Versucht, allerdings ohne Erfolg.......

Vielen Dank vorab.
Gruß
Kyle-e

 

Nach weiteren Tests habe ich es dann doch selber geschafft.
Trotzdem vielen Dank für den Code!!!

Gruß
kyle-e