Makro zum automatischen kopieren fehlerhaft
08.07.2015 16:10:56
Freisiedler
da ich hier schon öfters gute Tipps gefunden habe, hoffe ich, dass ihr mir diesmal auch weiterhelfen könnt :)
Ausgangslage:
Ich besitze einen Ordner mit einer beliebigen Anzahl von Ergebnisdateien. Diese sollen, um Werte raus zu kopieren, nacheinander geöffnet und wieder geschlossen werden. Die kopierten Daten sollen anschließend nebeneinander in die Tabelle1 eingefügt werden. Das Layout der Dateien sieht dabei immer gleich aus. Lediglich die Anzahl an Zeilen kann sich variieren.
Mein, bis jetzt, zusammengeschustertes Skript ermöglicht es schon einmal einen festen Bereich der Tabellen zu kopieren. Als Beispiel besitzen die Dateien in der Spalte A immer den gleichen Wertebereich (Zeit), aber in Spalte B variierende Werte. Ziel ist es in Spalte A der Tabelle 1 die kopierte Zeit und in den restlichen Spalten die verschiedenen Werte zu haben. Das Problem ist, dass mir das Makro zwar Daten kopiert, jedoch übernimmt dieses nur die ersten beiden Werte. Die restlichen eingefügten Werte entsprechen dem zweiten Wert.
Option Explicit
Sub Pickup()
Dim strDatnam As String
Dim wb As Workbook
Dim strPfad As String
Dim rngEinfüg As Range
'Pfadnamen anpassen
strPfad = "C:\Ergebnisse Kalibrierung\"
strDatnam = Dir(strPfad & "*.xlsx")
Do While strDatnam ""
Set wb = Workbooks.Open(strPfad & strDatnam)
With ThisWorkbook.Sheets(1)
Set rngEinfüg = Tabelle1.Cells(2, 1)
rngEinfüg = wb.Sheets(1).[A2]
rngEinfüg.Offset(1, 0).Resize(199) = WorksheetFunction.Transpose(wb.Sheets(1). [A3:A201])
Set rngEinfüg = IIf(IsEmpty(Tabelle1.Cells(2, 2)), Tabelle1.Cells(2, 2), Tabelle1.Cells(2, _
_
Columns.Count).End(xlToLeft).Offset(0, 1))
rngEinfüg = wb.Sheets(1).[B2]
rngEinfüg.Offset(1, 0).Resize(199) = WorksheetFunction.Transpose(wb.Sheets(1).Range("B3: _
_
B201"))
End With
wb.Close savechanges:=False
strDatnam = Dir
Loop
Set rngEinfüg = Nothing
Set wb = Nothing
End Sub
Falls mir jemand, neben diesen Fehler, einen Tipp geben könnte wie ich Daten mit variierender Länge kopieren könnte, wäre ich sehr dankbar.
Liebe Grüße,
Freisiedler