Unterschiedl. Zellbereiche in neue Datei kopieren

Hallo zusammen,
habe nun schon einige Tage gegoogelt aber leider bin ich auch durch zusammenkopieren versch. Beispiele nicht wirklich in der Lage mir die passende Lösung für mein Problem zu basteln. Vielleicht könnt ihr mir ja helfen.
Folgendes Problem:
Ich möchte Excelformulare auslesen und als Tabelle in einer neuen Datei speichern
Ich habe mehrere Excel Dateien in einem Ordner (C:\Users\mb\Desktop\Test).Diese Dateien haben mehrere Tabellenblätter (unterschiedliche Anzahl & alle mit unterschiedlichem Namen).
Alle Tabellenblätter haben jedoch vom Format den selben Aufbau. (siehe Anhang)
In jedem Tabellenblatt stehen im Block C12:L65 zeilenwärts Werte. (allerdings in unregelmäßigen Abständen).
Ich möchte nun das mein Makro in diesem Block, Zeilen (bis Spalte J), in denen Werte in Spalte C stehen, herauskopiert und in eine neue Datei schreibt und jede Zeile mit den Werten aus D3, H3, L3, V3, Z3, AC3, AG3, P67, V67, U68, V69 anreichert.
Das soll automatisch fortlaufend für jede Datei und darin für jedes Tabellenblatt funktionieren. :D
Ich hoffe das ganze ist nicht zu kompliziert und meine Beispieldateien reichen zum Verständnis.
https://www.herber.de/bbs/user/121430.xlsx
(auzulesende Datei)
https://www.herber.de/bbs/user/121431.xlsx
(Bsp. Ergebnisdatei)
Grüße Marvin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Marvin,
nachstehendes Makro liest alle Excel-Dateien (*.xlsx) aus dem Verzeichnis C:\Users\mb\Desktop\Test ein und überträgt die Daten aus sämtlichen Tabellen dieser Dateien in die Zieldatei.

Sub DatenEinlesen()
Dim WB_Daten As Workbook, WB_Ziel As Workbook, ws As Worksheet, strDatei As String
Dim lZ As Long, lZ_Daten As Long, n As Long
Set WB_Ziel = ThisWorkbook
Application.ScreenUpdating = False
lZ = 2
With WB_Ziel.ActiveSheet
strDatei = Dir("C:\Users\mb\Desktop\Test\*.xlsx")
Do While strDatei  ""
Set WB_Daten = Workbooks.Open(Filename:=strDatei)
For Each ws In WB_Daten.Worksheets
lZ_Daten = ws.Range("C66").End(xlUp).Row
For n = 12 To lZ_Daten
If ws.Range("C" & n)  "" Then
.Range("A" & lZ & ":H" & lZ).Value = ws.Range("C" & n & ":J" & n).Value
.Range("I" & lZ).Value = ws.Range("D3").Value
.Range("J" & lZ).Value = ws.Range("H3").Value
.Range("K" & lZ).Value = ws.Range("L3").Value
.Range("L" & lZ).Value = ws.Range("V3").Value
.Range("M" & lZ).Value = ws.Range("Z3").Value
.Range("N" & lZ).Value = ws.Range("AC3").Value
.Range("O" & lZ).Value = ws.Range("AG3").Value
.Range("P" & lZ).Value = ws.Range("P67").Value
.Range("Q" & lZ).Value = ws.Range("V67").Value
.Range("R" & lZ).Value = ws.Range("U68").Value
.Range("S" & lZ).Value = ws.Range("V69").Value
lZ = lZ + 1
End If
Next n
Next ws
WB_Daten.Close
strDatei = Dir
Loop
End With
Set WB_Daten = Nothing
Application.ScreenUpdating = True
End Sub

https://www.herber.de/bbs/user/121434.xlsm
Gruß
Robert

Sub Test() Dim WB As Workbook Dim newWB As Workbook Dim rngBereich As Range Dim i As Integer Dim intLZ As Integer Set WB = ThisWorkbook Set rngBereich = WB.Sheets(1).Range("C12:L65") Set newWB = Application.Workbooks.Add With newWB rngBereich.Copy Destination:=.Sheets(1).Range("A1") intLZ = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row For i = intLZ To 1 Step -1 If .Sheets(1).Cells(i, 1).Value = "" Then .Sheets(1).Rows(i).EntireRow.Delete Else .Sheets(1).Cells(i, 10).Value = WB.Sheets(1).Range("D3") .Sheets(1).Cells(i, 11).Value = WB.Sheets(1).Range("H3") .Sheets(1).Cells(i, 12).Value = WB.Sheets(1).Range("L3") .Sheets(1).Cells(i, 13).Value = WB.Sheets(1).Range("V3") .Sheets(1).Cells(i, 14).Value = WB.Sheets(1).Range("Z3") .Sheets(1).Cells(i, 15).Value = WB.Sheets(1).Range("AC3") .Sheets(1).Cells(i, 16).Value = WB.Sheets(1).Range("AG3") .Sheets(1).Cells(i, 17).Value = WB.Sheets(1).Range("P67") .Sheets(1).Cells(i, 18).Value = WB.Sheets(1).Range("V67") .Sheets(1).Cells(i, 19).Value = WB.Sheets(1).Range("U68") .Sheets(1).Cells(i, 20).Value = WB.Sheets(1).Range("V69") End If Next i .SaveAs Filename:="Test.xlsx", FileFormat:=51 ' Dateiname noch anpassen End With Set WB = Nothing Set newWB = Nothing Set rngBereich = Nothing End Sub Grüße, Bernd

Beliebteste Forumthreads (12 Monate)

Unterschiedl. Zellbereiche in neue Datei kopieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Unterschiedl. Zellbereiche in neue Datei kopieren

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

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread