Daten auto. kopieren
10.08.2022 08:37:04
Ina
ich bräuchte bitte nochmal eure Hilfe und zwar würde ich gerne das Kopieren der Daten automatisch machen, mit einem Makro aufnehmen geht es leider nicht, da die Spalten oftmals an Größe varrieren.
Ich habe einen Beispieldatensatz hochgeladen, damit es mehr verständlich ist was ich meine.
Ich habe folgendes Problem und zwar möchte ich die Spalten wo Step steht kopieren in eine neue Tabelle, die Daten sollen aber quer gespeichert werden und er soll dynamisch kopieren dh manche Datenblätter haben 5 Steps, manche nur 2 usw., hinzu kommt das weiter unten die Punkte neben den Step ( auch dynamisch) mit kopiert werden sollen. Als Beispiel Step1 mit all seinen Daten und daneben E/P1 mit all seinen Daten. Wenn es für einen Step keinen Punkt(E/P) gibt, soll einfach automatisch 0 stehen. Natürlich sollen die Daten immer untereinander dann gespeichert werden ( siehe Beispiel und inkl. Code).
Falls es nicht verständlich genug ist, bitte einfach Bescheid geben!!
Ich hoffe sowas kann man automatisch machen und muss nicht per Hand ausgeführt werden, danke für eure Hilfe!!
https://www.herber.de/bbs/user/154577.xlsx
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LetzteZeile As Long
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Set ws2 = Workbooks("Tabelle_finish.xlsm").Worksheets("Sheet2")
Do While xFileName ""
Set ws1 = Workbooks.Open(xFdItem & xFileName).Sheets(1)
LetzteZeile = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row + 1
ws1.Range("B2").Copy ws2.Cells(LetzteZeile, 1)
ws1.Range("B5").Copy ws2.Cells(LetzteZeile, 2)
ws1.Range("B109").Copy ws2.Cells(LetzteZeile, 3)
ws1.Range("B110").Copy ws2.Cells(LetzteZeile, 4)
ws1.Parent.Close False
xFileName = Dir
Loop
End If
End Sub