Gleich strukturierte Excel-Dateien zusammenführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit 'Die Arbeitsmappe, die diesen Code enthält benötigt eine leere Tabelle "Main" 'Die Arbeitsmappe, die diesen Code enthält benötigt eine Tabelle "Sources" 'Die tausende Arbeitsmappen solltest Du in die Tabelle "Sources" importieren/einlesen Sub Datensammler() Dim myAM As Workbook Dim mySh As Worksheet Dim ze As Long 'Zeilenzähler Dim i As Long ' noch ein Zeilenzähler Dim t As Long 'variable für die "Treppe" Dim myFile As Range 'Dateinamen in Tabelle "Sources" incl. Pfadname in Spalte A ? Set myAM = ThisWorkbook Set mySh = myAM.Sheets("Main") 'Zeilenzähler; Variable mit Startwert belegen, Start in Zeile 1 ze = 1 'Schleife starten. Alle Dateien aus der Tabelle "Sources" nacheinander öffnen 'und mit nachfolgendem Code gewünschte Daten in die Tabelle "Main" hineinkopieren For Each myFile In Sheets("Sources").Range("A1:A2500") 'mehr als 2500 Dateien? Anpassen Workbooks.Open Filename:=myFile.Value With Sheets("Tabelle1") ' Tabellenname anpassen sofern nicht "Tabelle1" .Range("A1").Copy Destination:=mySh.Range("A" & ze) .Range("B1:D41").Copy Destintaion:=mySh.Range("B" & ze) .Range("E1:E3").Copy Destination:=mySh.Range("F" & ze) End With myFile.Close savechanges:=False 'In den Spalten F, G, H Zellen senkrecht verbinden Range(Cells(ze, 6), Cells(ze + 40, 6)).Merge Range(Cells(ze, 7), Cells(ze + 40, 7)).Merge Range(Cells(ze, 8), Cells(ze + 40, 8)).Merge 'Die Spalte C mit der gewünschten "Treppe runter & rauf" füllen t = -60 For i = 3 To 23 Cells(i, 3) = t t = t + 3 Next For i = 24 To 43 Cells(i, 3) = t t = t + 3 Next 'Zeilenzähler um 41 erhöhen; die nächsten Daten sollen angehängt werden ze = ze + 41 Next End Sub

Hallo Jochen
Zuerst einmal herzlichen Dank für Deine Unterstützung und für die Zeit, die Du dir genommen hast. Leider hat etwas nicht ganz geklappt bzw. diverse Fehler sind aufgetreten. Mit Debuggen bin ich nicht wirklich weitergekommen, daher versuche ich mit Beispieldateien das Problem nochmals zu schildern.
Hier sind zwei (der über 1000) Quelldateien:
https://www.herber.de/bbs/user/111653.xlsx
https://www.herber.de/bbs/user/111654.xlsx
In der ersten Quelldatei habe ich die relevanten Zellen farblich markiert. Die gleiche Farben habe ich in der Zieldatei verwendet, um zu verdeutlichen welche Zellen aus der Quelldatei in welche Zellen in die Zieldatei hineinkopiert werden sollen. Hier die Zieldatei:
https://www.herber.de/bbs/user/111655.xlsx
Nun zu den Fehler, die ich beim Ausführen Deines Codes erhalten habe:
- Die Tabellen heissen leider nicht Tabelle1, sonder jeweils wie die Datei selber. Habe ich aber mit einer Variable gelöst
- .Range("A1").Copy Destination:=mySh.Range("A" & ze), Das Problem ist hier, dass ich mit dem Wert A1 aus der Quelldatei die Zellen A1 bis A41 der Zieldatei füllen möchte. Dies ergibt zwar keine Fehlermeldung, der Wert wird aber jeweils nur in die Zelle A1, A42,....usw. geschrieben.
- .Range("B1:D41").Copy Destintaion:=mySh.Range("B" & ze), hier bekomme ich einen Laufzeitfehler. Meine Vermutung ist, dass Excel(oder VBA) ein Problem damit hat, ein Bereich in eine einzelne Zelle zu kopieren.
- myFile.Close savechanges:=False, Hier meckert VBA, dass die Methode Close nicht existiert
- 'In den Spalten F, G, H Zellen senkrecht verbinden
Range(Cells(ze, 6), Cells(ze + 40, 6)).Merge
Range(Cells(ze, 7), Cells(ze + 40, 7)).Merge
Range(Cells(ze, 8), Cells(ze + 40, 8)).Merge
Damit werden zwar die Zellen verbunden, aber nicht in der Zieldatei, sondern wird in der Quelldatei etwas gemacht.
Ich hoffe Du findest Zeit um meine Antwort zu anzuschauen und hast vielleicht der eine oder andere Tipp um die Fehler zu beheben. Alle Hilfen sind auf jeden Fall willkommen und werden auch sehr geschätzt. Besten Dank.
Gruss
Alex

Hallo Jochen,
Nochmals herzlichen Dank für Deine Unterstützung und entschuldige mich für die verspätete Antwort. Das "Problem" ist privater Natur (Auswertung von Sensormessdaten) und kann tagsüber im Geschäft nicht daran arbeiten. Daher bin ich erst heute Abend dazu gekommen Deine Lösungen auszuprobieren.
Du hast mir wirklich eine Menge Arbeit erspart und dazu habe ich noch einiges gelernt. Dafür wirklich nochmals herzlichen Dank. Ich weiss leider nicht wie ich mich revanchieren kann, mit VBA-Tipps wird es für mich schwierig sein. Aber wenn Du z.B. etwas aus der Schweiz benötigst, einfach melden...
Zurück zur Lösung, ich habe noch einige Anpassungen gemacht.
Die Spaltenübersetzung habe ich aufgetrennt, damit die Spalten C und D beide übernommen werden, ansonsten würde die Spalte C durch die "Treppe" ersetzt werden und die Spalte E wäre leer in der Zieldatei.
Deine Korrektur für die Treppe funktioniert ebenfalls super.
Hier nochmals die vollständige Lösung, evtl. kann davon sonst noch jemand profitieren:
Option Explicit
'Die Arbeitsmappe, die diesen Code enthält benötigt eine leere Tabelle "Main"
'Die Arbeitsmappe, die diesen Code enthält benötigt eine Tabelle "Sources"
'Die tausende Arbeitsmappen solltest Du in die Tabelle "Sources" importieren/einlesen


Sub Datensammler()
Dim myAM As Workbook
Dim mySh As Worksheet
Dim ze As Long 'Zeilenzähler
Dim i As Long ' noch ein Zeilenzähler
Dim t As Long 'variable für die "Treppe"
Dim myFile As Range 'Dateinamen in Tabelle "Sources" incl. Pfadname in Spalte A ?
Set myAM = ThisWorkbook
Set mySh = myAM.Sheets("Main")
Application.ScreenUpdating = False
'Alle Daten aus Tabelle "Main" löschen
mySh.Cells.Delete
'Zeilenzähler; Variable mit Startwert belegen, Start in Zeile 1
ze = 1
'Schleife starten. Alle Dateien aus der Tabelle "Sources" nacheinander öffnen
'und mit  nachfolgendem Code gewünschte Daten in die Tabelle "Main" hineinkopieren
For Each myFile In Sheets("Sources").Range("A1:A2") 'mehr als 2500 Dateien? Anpassen
Workbooks.Open Filename:=myFile.Value
With Sheets(1) ' Tabellenname anpassen sofern nicht "Tabelle1"
.Range("A1").Copy Destination:=mySh.Range("A" & ze)
.Range("B1:B41").Copy Destination:=mySh.Range("B" & ze)
.Range("C1:C41").Copy Destination:=mySh.Range("D" & ze)
.Range("D1:D41").Copy Destination:=mySh.Range("E" & ze)
.Range("E1").Copy Destination:=mySh.Range("F" & ze)
.Range("E2").Copy Destination:=mySh.Range("G" & ze)
.Range("E3").Copy Destination:=mySh.Range("H" & ze)
mySh.Range("A" & ze).Copy
mySh.Range("A" & ze + 1 & ":A" & ze + 40).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
ActiveWorkbook.Close savechanges:=False
With mySh
'In den Spalten F, G, H Zellen senkrecht verbinden
.Range(Cells(ze, 6), Cells(ze + 40, 6)).Merge
.Cells(ze, 6).HorizontalAlignment = xlCenter
.Cells(ze, 6).VerticalAlignment = xlCenter
.Cells(ze, 7).HorizontalAlignment = xlCenter
.Cells(ze, 7).VerticalAlignment = xlCenter
.Cells(ze, 8).HorizontalAlignment = xlCenter
.Cells(ze, 8).VerticalAlignment = xlCenter
.Range(Cells(ze, 7), Cells(ze + 40, 7)).Merge
.Range(Cells(ze, 8), Cells(ze + 40, 8)).Merge
'Die Spalte C mit der gewünschten "Treppe runter & rauf" füllen
t = -60
For i = ze To ze + 20
.Cells(i, 3) = t
t = t + 3
Next
For i = ze + 21 To ze + 40
.Cells(i, 3) = t
t = t + 3
Next
'Zeilenzähler um 41 erhöhen; die nächsten Daten sollen angehängt werden
ze = ze + 41
End With
Next
With Columns("A:A")
.Replace What:=".000000", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.HorizontalAlignment = xlCenter
End With
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Viele Grüsse aus der Schweiz
Alex

Beliebteste Forumthreads (12 Monate)

Gleich strukturierte Excel-Dateien zusammenführen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread