Excel 2007 Dateien mittels VBA zusammenführen

mirkoH · 14. Januar 2011 um 23:04

Hallo zusammen,

Ich habe ca 50 Dateien Excel 2007 (in einem Ordner), die von der Formatierung her identisch sind in eine zusammenzuführen. Da ich dies jeden Tag machen muss, benötige ich einen VBA-Code der mir dies automatisch macht. Die Dateien haben ca. 20 Spalten und ca. 9000 Zeilen.

Bei den im Netz angebotenen Codes bekomme ich immer einen Laufzeitfehler. Hat jemand einen Code für mich, der hierfür funktioniert?

Vielen Dank im voraus und Viele Grüße

Mirko

dsoetebeer_web_de · 14. Januar 2011 um 23:13

Hallo,

bitte gib mir den nicht funkttionierenden VBA-Code.

Beschreibe zusätzlich, wie die Excel-Dateien zusammengeführt werden sollen.

Möglich wäre…

Inhalte alle in einer Tabelle
Inhalt jeweils einer Datei in seperaten Tabellen einfügen

Viele Grüße,
BigBen

mirkoH · 15. Januar 2011 um 10:27

Hallo BigBen,

Danke für die schnelle Antwort.

Meine Dateien bestehen 20 Spalten und ca. 9000. Zeilen.
Diese stehen alle in Tabelle 1. Die Überschriften sind Name, Kundennr. Tag, Betrag usw. In Spalte O sind Sie gefiltert nach der jeweiligen Zuständigkeit.

Jetzt brauche ich diese Daten in einer neuen Tabelle zusammengefasst.

Der Script den ich im Internet gefunden hatte lautete wie folgt:

Sub makro1()
Worksheets(1).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Range(„A1“).Select
aname = ActiveWorkbook.Name

pfad1 = ActiveWorkbook.Path & „“
name1 = Dir(pfad1, vbNormal)

Do While name1 „“
If name1 aname Then
If Right(name1, 4) = „.xlsx“ Then
GoSub uebernehmen
End If
End If
name1 = Dir
Loop
Cells.Select
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
Exit Sub

uebernehmen:
Workbooks.Open Filename:=pfad1 & name1
Worksheets(1).Activate
lz = Range(„b65536“).End(xlUp).Row
If lz > 1 Then
Range(Cells(2, 2), Cells(lz, 18)).Select
Selection.Copy
Windows(aname).Activate
l1 = Range(„a65536“).End(xlUp).Row + 1
Cells(l1, 2).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.DisplayAlerts = False
Windows(name1).Close
Application.DisplayAlerts = True
l2 = Range(„b65536“).End(xlUp).Row
Range(Cells(l1, 1), Cells(l2, 1)) = name1

Else
Windows(name1).Close
End If
Return
End Sub

Der andere hier Sammeln() aber den finde ich leider im Moment nicht mehr.

Danke für deine Hilfe.

Viele Grüße

Mirko

Reinhard_Kraasch · 15. Januar 2011 um 13:20

Ich habe ca 50 Dateien Excel 2007 (in einem Ordner), die von
der Formatierung her identisch sind in eine zusammenzuführen.
Da ich dies jeden Tag machen muss, benötige ich einen VBA-Code
der mir dies automatisch macht. Die Dateien haben ca. 20
Spalten und ca. 9000 Zeilen.

Bei den im Netz angebotenen Codes bekomme ich immer einen
Laufzeitfehler. Hat jemand einen Code für mich, der hierfür
funktioniert?

Was heißt denn „zusammenführen“ für dich?

Und was für Code verwendest du bzw. welchen Fehler bekommst du?

Gruß
Reinhard Kraasch

dsoetebeer_web_de · 15. Januar 2011 um 18:32

Hallo mirkoH,

Der von Dir gelieferte VBA-Code funktioniert im wesentlichen korrekt.

Man musste lediglich einige Zeilen anpassen.

Viele Grüße,
BigBen

— VBA-Code —

Option Explicit

Sub makro1()

Dim Pfad1 As String, name1 As String, aName As String

Worksheets(1).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Range(„A1“).Select
aName = ActiveWorkbook.Name

Pfad1 = ActiveWorkbook.Path & „“
name1 = Dir(Pfad1, vbNormal)

Do While name1 „“
If name1 aName Then
If Right(name1, 4) = „.xlsx“ Then
Call uebernehmen(Pfad1, name1, aName)
End If
End If
name1 = Dir
Loop
Cells.Select
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
End Sub

Sub uebernehmen(Pfad1 As String, name1 As String, aName As String)

Dim lz As Long, l1 As Long, l2 As Long

'uebernehmen:
Workbooks.Open Filename:=Pfad1 & name1
Worksheets(1).Activate
lz = Range(„b65536“).End(xlUp).Row
If lz > 1 Then
Range(Cells(2, 2), Cells(lz, 18)).Select
Selection.Copy
Windows(aName).Activate
l1 = Range(„a65536“).End(xlUp).Row + 1
Cells(l1, 2).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = False
Windows(name1).Close
Application.DisplayAlerts = True
l2 = Range(„b65536“).End(xlUp).Row
Range(Cells(l1, 1), Cells(l2, 1)) = name1

Else
Windows(name1).Close
End If
'Return
End Sub

mirkoH · 15. Januar 2011 um 20:50

Hallo Hr. Kraasch.

Meine Dateien bestehen aus 20 Spalten und ca. 9000. Zeilen.
Diese stehen alle in Tabelle 1. Die Überschriften sind Name, Kundennr. Tag, Betrag usw. In Spalte O sind Sie gefiltert nach der jeweiligen Zuständigkeit.

Jetzt brauche ich diese Daten in einer neuen Tabelle zusammengefasst.

Der Script den ich im Internet gefunden hatte lautete wie folgt:

Meine Dateien bestehen 20 Spalten und ca. 9000. Zeilen.
Diese stehen alle in Tabelle 1. Die Überschriften sind Name, Kundennr. Tag, Betrag usw. In Spalte O sind Sie gefiltert nach der jeweiligen Zuständigkeit.

Jetzt brauche ich diese Daten in einer neuen Tabelle zusammengefasst.

Der Script den ich im Internet gefunden hatte lautete wie folgt:

Option Explicit
Sub Sammeln()

Dim FName$, FCount%, R%, c%, nC, i&
Dim Bereich As Range
Dim FileArray()
Dim ProcessCounter As Integer
Application.ScreenUpdating = False
ChDrive „d“
ChDir „d:\Testordner“
FName = Dir("*.xlsx")

Do While FName „“
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop

i = 1

For ProcessCounter = 1 To FCount
Application.DisplayAlerts = False
Workbooks.Open FileArray(ProcessCounter)
On Error Resume Next
R = Cells.Find("*", [a1], , , xlByRows, _
xlPrevious).Row
c = Cells.Find("*", [a1], , , _
xlByColumns, xlPrevious).Column
If Err = 91 Then GoTo WEITER1
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(1, 1), Cells(R, c))
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R + 1
On Error GoTo 0
WEITER1:
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next ProcessCounter
End Sub

Ich bekomme den Laufzeitfehler 1004 Die Methode 'Open für das Objekt ‚Workbooks‘ ist fehlgeschlagen.

Danke im voraus.

Mirko

mirkoH · 15. Januar 2011 um 20:53

Hallo mirkoH,

Der von Dir gelieferte VBA-Code funktioniert im wesentlichen
korrekt.

Man musste lediglich einige Zeilen anpassen.

Viele Grüße,
BigBen

Hallo BigBen,

jetzt tut sich leider gar nichts mehr. Hier ist der andere Code den ich heute morgen meinte. Vielleicht kannst du mir diesen auch noch optimieren?

Danke im voraus

Mirko

Option Explicit
Sub Sammeln()

Dim FName$, FCount%, R%, c%, nC, i&
Dim Bereich As Range
Dim FileArray()
Dim ProcessCounter As Integer
Application.ScreenUpdating = False
ChDrive „d“
ChDir „d:\Testordner“
FName = Dir("*.xlsx")

Do While FName „“
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop

i = 1

For ProcessCounter = 1 To FCount
Application.DisplayAlerts = False
Workbooks.Open FileArray(ProcessCounter)
On Error Resume Next
R = Cells.Find("*", [a1], , , xlByRows, _
xlPrevious).Row
c = Cells.Find("*", [a1], , , _
xlByColumns, xlPrevious).Column
If Err = 91 Then GoTo WEITER1
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(1, 1), Cells(R, c))
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R + 1
On Error GoTo 0
WEITER1:
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next ProcessCounter
End Sub

Ich bekomme den Laufzeitfehler 1004 Die Methode 'Open für das Objekt ‚Workbooks‘ ist fehlgeschlagen.

Danke im voraus.

Mirko

— VBA-Code —

Option Explicit

Sub makro1()

Dim Pfad1 As String, name1 As String, aName As String

Worksheets(1).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Range(„A1“).Select
aName = ActiveWorkbook.Name

Pfad1 = ActiveWorkbook.Path & „“
name1 = Dir(Pfad1, vbNormal)

Do While name1 „“
If name1 aName Then
If Right(name1, 4) = „.xlsx“ Then
Call uebernehmen(Pfad1, name1, aName)
End If
End If
name1 = Dir
Loop
Cells.Select
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
End Sub

Sub uebernehmen(Pfad1 As String, name1 As String, aName As
String)

Dim lz As Long, l1 As Long, l2 As Long

'uebernehmen:
Workbooks.Open Filename:=Pfad1 & name1
Worksheets(1).Activate
lz = Range(„b65536“).End(xlUp).Row
If lz > 1 Then
Range(Cells(2, 2), Cells(lz, 18)).Select
Selection.Copy
Windows(aName).Activate
l1 = Range(„a65536“).End(xlUp).Row + 1
Cells(l1, 2).Activate
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = False
Windows(name1).Close
Application.DisplayAlerts = True
l2 = Range(„b65536“).End(xlUp).Row
Range(Cells(l1, 1), Cells(l2, 1)) = name1

Else
Windows(name1).Close
End If
'Return
End Sub

dsoetebeer_web_de · 16. Januar 2011 um 09:01

Hallo mrkoH,

Der Fehler 1004 tritt dann auf, wenn eine Datei nicht geöffnet werden kann.

Der VBA-Code wurde dahingehend angepasst, dass dieser anstelle des Laufzeitfehlers den Namen der Datei anzeigt.

Viele Grüße,
BigBen

— VBA-Code —
Option Explicit

Sub Sammeln()

Dim FName$, FCount%, R%, c%, nC, i&
Dim Bereich As Range
Dim FileArray()
Dim ProcessCounter As Integer
Application.ScreenUpdating = False
ChDrive „d“
ChDir „d:\Testordner“
FName = Dir("*.xlsx")

Do While FName „“
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop

i = 1

For ProcessCounter = 1 To FCount
Application.DisplayAlerts = False
On Error Resume Next
Err.Clear
Workbooks.Open FileArray(ProcessCounter)
If Err.Number 0 Then
MsgBox „Beim Öffnen der Datei „““ & FileArray(ProcessCounter) & „“" trat ein Fehler auf.", vbCritical
Exit Sub
End If
’ On Error Resume Next
R = Cells.Find("*", [a1], , , xlByRows, _
xlPrevious).Row
c = Cells.Find("*", [a1], , , _
xlByColumns, xlPrevious).Column
If Err = 91 Then GoTo WEITER1
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(1, 1), Cells(R, c))
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R + 1
On Error GoTo 0
WEITER1:
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next ProcessCounter
End Sub

mirkoH · 16. Januar 2011 um 20:32

Danke,

jetzt läuft es so, wie ich es wollte. Ich habe zwar noch einen kleinen Schönheitsfehler, dass auf Grund der ausgefilterten Dateien, die Daten nicht in den Zeilen an 2 stehen, extrem viele Leerzeilen beim zusammenführen entstehen.

Vielleicht hast du da ja noch eine Lösung?

Viele Grüße

Mirko

dsoetebeer_web_de · 16. Januar 2011 um 21:04

Hallon mirkoH,

freut mich, dass es jetzt fast so läuft, wie es soll.

Ich verstehe nicht so recht, was du meinst mit den Zeilen, an denen „2“ stehen.

Ist hier eine ganze Zeile ohne Inhalte entstanden?

Teile mir einfach mit, welche Spalten auf Inhalte geprüft werden müssen? z.B. Spalte B - F

Viele Grüße,
BigBen

mirkoH · 16. Januar 2011 um 21:39

Hi Big Ben,

Im Prinzip reicht es, wenn die Spalte A überprüft wird. Wenn diese leer ist, dann ist auch der Rest leer.

Danke

Mirko

Reinhard_Kraasch · 16. Januar 2011 um 22:56

Hallo Hr. Kraasch.

Meine Dateien bestehen aus 20 Spalten und ca. 9000. Zeilen.
Diese stehen alle in Tabelle 1. Die Überschriften sind Name,
Kundennr. Tag, Betrag usw. In Spalte O sind Sie gefiltert nach
der jeweiligen Zuständigkeit.

Jetzt brauche ich diese Daten in einer neuen Tabelle
zusammengefasst.

Der Script den ich im Internet gefunden hatte lautete wie
folgt:

Meine Dateien bestehen 20 Spalten und ca. 9000. Zeilen.
Diese stehen alle in Tabelle 1. Die Überschriften sind Name,
Kundennr. Tag, Betrag usw. In Spalte O sind Sie gefiltert nach
der jeweiligen Zuständigkeit.

Jetzt brauche ich diese Daten in einer neuen Tabelle
zusammengefasst.

Der Script den ich im Internet gefunden hatte lautete wie
folgt:
Ich bekomme den Laufzeitfehler 1004 Die Methode 'Open für das
Objekt ‚Workbooks‘ ist fehlgeschlagen.

Danke im voraus.

Mirko

Also bei mir funktioniert der Code wunderbar. Um welche Excel-Version geht es denn?

Versuch mal folgendes:

Oben:

FName = Dir("D:\Testordner\*.xlsx")

und weiter unten dann:

Workbooks.Open "D:\Testordner\" & FileArray(ProcessCounter)

Gruß
Reinhard Kraasch

Reinhard_Kraasch · 16. Januar 2011 um 22:58

Zu spät gelesen „Excel 2007“…

Hab ich jetzt gerade nicht am Laufen (ich hab’s unter Excel 2003 getestet).

Gruß
Reinhard Kraasch

dsoetebeer_web_de · 22. Januar 2011 um 17:53

Hallo mirkoH,

die vorliegende Version löscht aus den zu kopierenden Daten leere Zeilen.

Viele Grüße,
BigBen

Option Explicit

Sub Sammeln()

Dim rngRow As Range
Dim FName$, FCount%, R%, c%, nC, i&
Dim Bereich As Range
Dim FileArray()
Dim ProcessCounter As Integer
Application.ScreenUpdating = False
ChDrive „d“
ChDir „d:\Testordner“
FName = Dir("*.xlsx")

Do While FName „“
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop

i = 1

For ProcessCounter = 1 To FCount
Application.DisplayAlerts = False
On Error Resume Next
Err.Clear
Workbooks.Open FileArray(ProcessCounter)
If Err.Number 0 Then
MsgBox „Beim Öffnen der Datei „““ & FileArray(ProcessCounter) & „“" trat ein Fehler auf.", vbCritical
Exit Sub
End If
’ On Error Resume Next
Set rngRow = ActiveSheet.UsedRange.Find("")
Do Until rngRow Is Nothing
ActiveSheet.UsedRange.Rows(rngRow.Row).Delete
Set rngRow = ActiveSheet.UsedRange.FindNext
Loop
R = Cells.Find("*", [a1], , , xlByRows, _
xlPrevious).Row
c = Cells.Find("*", [a1], , , _
xlByColumns, xlPrevious).Column
If Err = 91 Then GoTo WEITER1
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(1, 1), Cells(R, c))
If Tabelle1.Cells(i, 1).Formula „“ Then i = i + 1
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R ’ + 1
On Error GoTo 0
WEITER1:
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next ProcessCounter
End Sub

JavelinX · 24. Oktober 2011 um 16:19

Hallo zusammen,

entschuldigt die Threadnekromantie aber das ist das erste Makro das bei mir funktioniert. Aber ich hätte eine Frage: kann man das so abändern, dass die ersten 2 Zeilen entweder nur einmal ganz oben aufgeführt werden oder aber ganz ignoriert werden? Wobei mir ersteres eigentlich lieber wäre…

Danke

mirkoH · 24. Oktober 2011 um 19:51

Hi JavelinX
Versuch es mal damit:
Aus der ersten Datei werden sämtliche Zeilen übernommen und aus den anderen erst die Zeilen ab Zeile 3.

Viele Grüße

Mirko

Sub Sammeln()

Dim rngRow As Range
Dim FName$, FCount%, R%, c%, nC, i&
Dim Bereich As Range
Dim FileArray()
Dim ProcessCounter As Integer
Application.ScreenUpdating = False
ChDrive „d“
ChDir „d:\Testordner“
FName = Dir("*.xlsx")

Do While FName „“
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop

i = 1
ProcessCounter = 1

Application.DisplayAlerts = False
Workbooks.Open FileArray(ProcessCounter)
With Range(„A1“).CurrentRegion
.TextToColumns DataType:=xlDelimited
R = .Rows.Count
c = .Columns.Count
End With
If Err = 91 Then GoTo WEITER0
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(1, 1), Cells(R, c))
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R + 1
WEITER0:
ActiveWorkbook.Close
Application.DisplayAlerts = True

For ProcessCounter = 2 To FCount
Application.DisplayAlerts = False
Workbooks.Open FileArray(ProcessCounter)
On Error Resume Next
With Range(„A1“).CurrentRegion
.TextToColumns DataType:=xlDelimited
R = .Rows.Count
c = .Columns.Count
End With
If Err = 91 Then GoTo WEITER1
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(3, 1), Cells(R, c))
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R + 1
On Error GoTo 0
WEITER1:
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next ProcessCounter
End Sub