VBA: Splaten aus mehreren Excel kopieren

Hallo zusammen,
ich konnte schon viele Information aus dem Forum gewinnen, wo andere ähnliche Anforderungen hatten, wie ich. Da haben meist kleinere Anpassungen zum Ziel geführt. Vielen Dank dafür!!!
Nun stehe ich aber vor einem Problem, welches ich noch nicht finden/lösen konnte.
Ich muss einen Abgleich der Materialsituation fahren, wo ich aus den Begehungsprotokollen das angezogene Material mit dem dann tatsächlich geliefertem Material gegenüberstellen muss.
Dafür hatte ich auch schon ein VBA zusammenkopiert, diese Variante fügt mir aber die Einträge aller Excel aus dem Ordner untereinander in eine neue Excel ein. Dies erzeugt bei 30 Dateien dann ca. 59000 Zeilen in der neuen Datei, was das spätere Arbeiten mit der Datei sehr verlangsamt. Momentan wird die Materialbezeichnung und Stückzahl untereinander ab Spalte B, sowie der Dateiname (in erste Spalte) eingefügt. Auch dauert diese Zusammenführung bei ca. 30 Dateien gute 20 min.
Mein Gedanke ist nun, dass die Datei wesentlich kleiner wäre, wenn ich nur die Spalten mit den Stückzahlen in eine bestimmte Spalte der neuen Excel kopiere, wo die Materialpositionen schon voreingetragen sind (immer gleich, da Gesamtliste). Und in der obersten Zelle der Spalte sollte dann der Namen der Excel Datei eingetragen werden.
Nun mal präziese:
Ich habe mehrere .xlsx Dateien in einem Ordner, welche alle die gleiche Struktur haben.
Aus diesen Excel Dateien benötige ich immer aus dem Reiter Site Material die Zellen C4:C1964,
Diese sollen in der neuen Datei in dem Reiter "SSTI zu 643" in die Zellen C2:C1962 kopiert werden, in der Zelle C1 soll der Dateiname stehen. Dann soll das Makro die nächste Dateien nehmen und die Daten dann in dem Reiter "SSTI zu 643" in den Zellen D2:D1962 einfügen und den Dateinamen wieder in die Zelle D1.
Und dies dann fortlaufend mit allen Excel in dem Ordner.
Ich hoffe wirklich, hier kann mir jemand helfen.
Vielen Dank.
Achso, ich verwende Office 2016, was in der Version noch auswählbar ist.
Gruß, Electribe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub MWTabellenAusMehrerenDateienEinlesen() Dim oTargetSheet As Object Dim oSourceBook As Object Dim sPfad As String Dim sDatei As String Dim lErgebnisZeile As Long Dim s As Long Dim z As Long Application.ScreenUpdating = False 'Das "Flackern" ausstellen 'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen Set oTargetSheet = ActiveWorkbook.Sheets.Add lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1 'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis sPfad = "E:\SSTI Import\" sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien Do While sDatei "" 'Schritt 3: öffnen der Datei und Datenübertragung Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen 'Datenübertragung alle genutzten Zeilen und Spalten For z = 1 To oSourceBook.Sheets("Site Material").UsedRange.Rows.Count 'Keine Leerzeilen verarbeiten If Trim(CStr(oSourceBook.Sheets("Site Material").Cells(z, 2).Value)) "" Then For s = 1 To 3 'Spalte 1 - Dateinamen T oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei 'Spalte 2 bis 4 - Tabelleninhalte des Arbeitsblattes "Site Material" oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = _ oSourceBook.Sheets("Site Material").Cells(z, s).Value Next s lErgebnisZeile = lErgebnisZeile + 1 End If Next z 'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde oSourceBook.Close False 'nicht speichern 'Nächste Datei sDatei = Dir() Loop Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten 'Variablen aufräumen Set oTargetSheet = Nothing Set oSourceBook = Nothing End Sub

Sub MWTabellenAusMehrerenDateienEinlesen() Dim wksTargetSheet As Worksheet Dim wkbSourceBook As Workbook Dim wksSourceSheet As Worksheet Dim sPfad As String Dim sDatei As String Dim s As Long Dim z As Long Dim objDaten As Object, arrOut(), oObj, n As Long, tmp, i As Integer Set objDaten = CreateObject("scripting.dictionary") Application.ScreenUpdating = False 'Das "Flackern" ausstellen 'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen Set wksTargetSheet = ActiveWorkbook.Sheets.Add 'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis sPfad = "E:\SSTI Import\" sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien Do While sDatei "" 'Schritt 3: öffnen der Datei und Daten sammeln Set wkbSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen Set wksSourceSheet = wkbSourceBook.Sheets("Site Material") 'Datenübertragung alle genutzten Zeilen und Spalten For z = 1 To wksSourceSheet.UsedRange.Rows.Count 'Keine Leerzeilen verarbeiten If Trim(CStr(wksSourceSheet.Cells(z, 2).Value)) "" Then objDaten(sDatei & "_" & z) = wksSourceSheet.Cells(z, 2).Resize(, 3) End If Next z 'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde wkbSourceBook.Close False 'nicht speichern 'Nächste Datei sDatei = Dir() Loop 'Daten in Array schaufeln und im Sheet ausgeben ReDim arrOut(1 To objDaten.Count, 1 To 4) For Each oObj In objDaten n = n + 1 tmp = objDaten(oObj) arrOut(n, 1) = Split(oObj, "_")(0) 'dateiname For i = 1 To 3 arrOut(n, i + 1) = tmp(1, i) Next Next oObj wksTargetSheet.Cells(1, 1).Resize(UBound(arrOut), UBound(arrOut, 4)) = arrOut 'Variablen aufräumen Set wksTargetSheet = Nothing Set wkbSourceBook = Nothing End Sub

Sub aaaa() Dim wkb As Workbook, strFile As String Dim lngColumn As Long, wksZ As Worksheet lngColumn = 2 Const strPfad As String = "c:\test\" 'anpassen Set wksZ = ThisWorkbook.Sheets("SSTI zu 643") Application.ScreenUpdating = False strFile = Dir(strPfad & "*.xlsx", vbNormal) Do While strFile "" If strFile ThisWorkbook.Name Then lngColumn = lngColumn + 1 Set wkb = Workbooks.Open(strPfad & strFile) wkb.Sheets("Site Material").Range("C4:C1964").Copy wksZ.Cells(2, lngColumn) wksZ.Cells(1, lngColumn) = strFile wkb.Close False strFile = Dir End If strFile = Dir Loop End Sub

Sub Spalten() Dim wkb As Workbook, strFile As String Dim lngColumn As Long, wksZ As Worksheet lngColumn = 2 Const strPfad As String = "E:\SSTI Import\" 'anpassen Set wksZ = ThisWorkbook.Sheets("SSTI zu 643") Application.ScreenUpdating = False strFile = Dir(strPfad & "*.xlsx", vbNormal) Do While strFile "" If strFile ThisWorkbook.Name Then lngColumn = lngColumn + 1 Set wkb = Workbooks.Open(strPfad & strFile) wkb.Sheets("Site Material").Range("C4:C1964").Copy wksZ.Cells(2, lngColumn) wksZ.Cells(1, lngColumn) = strFile wkb.Close False End If strFile = Dir() Loop End Sub

Hallo Zusammen,
Vielen Dank für den Hinweis, aber es ist eine genrierte Vorlage, welche sich nur ein bis zwei mal im Jahr ändert, wo ich dann meine Zielvorlage einfach anpassen kann.
Nun habe ich aber mit dieser Excel Datei mehrere Probleme, nachdem ich die kompletten Daten eingelesen habe, ist die Datei nicht zu gebrauchen, da schon nur Filtern eine Wartezeit von mehreren Mintuen hervorruft.
Allersdings muss ich noch einige Abgleiche mit einer weiteren eingelesen Datei per Formel ermitteln muss.
Wobei die Automatische Berechnung bereits deaktiviert ist.
Nun habe ich alle mir eingefallen Varianten probiert und bin zu dem Entschluss gekommen ich muss selektieren, da ich eigentlich nur Teilbereiche (z.B.: A3:C169 und A194:C195 .... A1885:C1886) benötige, da andere Daten andere Serviceleistungen darstellen, welche ich nicht auswerte für meinen Vergleich. In Summe entstehen so pro eingelesene Datei nur c.a. 300 Zeilen, anstelle der momentanen 1960. Dies sollte die spätere Arbeitsmappe dann besser bedienbar machen, da ich die Daten dann übergebe.
Auch musste ich feststellen, die erste Variante alles untereinander aufzulisten, macht eine spätere Navigation wesentlich einfacher.
Ich würde somit gern bei diesem Makro den Auswahlbereich der Quelle auf unterschiedliche Bereiche begrenzen wollen. (z.B.: A3:C169 und A194:C195 .... A1885:C1886)
Allerdings komme ich mit den z s Koordinaten, oder Bezügen nicht klar, da es sich hier nicht um Z1S1 Bezüge handelt.
Kann mir hier vielleicht nochmal jemand helfen? Danke
hier nochmal das Makro, was die kompletten ersten drei Spalten einliest und angepasst werden müsste:

Sub MWTabellenAusMehrerenDateienEinlesen()
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As String
Dim lErgebnisZeile As Long
Dim s As Long
Dim z As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
Set oTargetSheet = ActiveWorkbook.Sheets.Add
lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "E:\SSTI Import\"
sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
Do While sDatei  ""
'Schritt 3: öffnen der Datei und Datenübertragung
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
'Datenübertragung alle genutzten Zeilen und Spalten
For z = 1 To oSourceBook.Sheets("Site Material").UsedRange.Rows.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSourceBook.Sheets("Site Material").Cells(z, 2).Value))  "" Then
For s = 1 To 3
'Spalte 1 - Dateinamen T
oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei
'Spalte 2 bis 4 - Tabelleninhalte des Arbeitsblattes "Site Material"
oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = _
oSourceBook.Sheets("Site Material").Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1
End If
Next z
'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
oSourceBook.Close False 'nicht speichern
'Nächste Datei
sDatei = Dir()
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub

Vielen Dank!
Gruß, Chris

Beliebteste Forumthreads (12 Monate)

VBA: Splaten aus mehreren Excel kopieren

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread