Makro zum automatischen kopieren fehlerhaft

Bild

Betrifft: Makro zum automatischen kopieren fehlerhaft
von: Freisiedler
Geschrieben am: 08.07.2015 16:10:56

Hallo Zusammen,
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

Bild

Betrifft: Beispieldatei?
von: Michael
Geschrieben am: 10.07.2015 20:58:02
Hi Freisiedler,
ich verstehe, ehrlich gesagt, nicht recht, was Du da treibst.
Mit der Schleife über mehrere Datein kommst Du ja offensichtlich zurecht, also lade uns doch bitte mal *eine* Datei hoch mit einem Tabellenblatt, das die Struktur der ersten Datei (die mit dem Makro) enthält und vielleicht ein, zwei Blätter mit der zu importierenden Struktur.
Dann können wir uns besser vorstellen, was wohin soll und die Geschichte konkret ansehen.
Wenn jemand ne Lösung hat, kannst Du sie ja wieder auf mehrere Datein ändern.
(Ich finde hier zip-files mit 5 Datein ziemlich lästig, darum geht's)
Schöne Grüße,
Michael

Bild

Betrifft: AW: Makro zum automatischen kopieren fehlerhaft
von: fcs
Geschrieben am: 11.07.2015 00:25:58
Hallo Freisiedler,
mit den folgenden Anpassungen sollte es funktionieren.
Gruß
Franz

Sub Pickup()
    Dim strDatnam As String
    Dim wb As Workbook
    Dim strPfad As String
    
    Dim wksZiel As Worksheet, wksQuelle As Worksheet
    Dim rngCopy As Range
    Dim lngZeile As Long, lngSpalte As Long
    Dim Zeile1_C As Long, Zeile1_E As Long
    
    'Pfadnamen anpassen
    strPfad = "C:\Ergebnisse Kalibrierung\"
'    strPfad = "C:\Users\Public\Test\AL\"
    strDatnam = Dir(strPfad & "*.xlsx")
    Zeile1_C = 2 '1. zu kopierende Zeile in den Quelldateien
    Zeile1_E = 2 'Zeile ab der zu kopierende Daten eingefügt werden sollen
    
    Set wksZiel = ActiveWorkbook.Sheets(1) 'ThisWorkbook.Sheets(1)
    lngSpalte = 1
    Application.ScreenUpdating = False
    Do While strDatnam <> ""
       Set wb = Workbooks.Open(strPfad & strDatnam, ReadOnly:=True)
       
       With wb.Sheets(1)
            lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
            If lngSpalte = 1 Then
                'Zeitwerte in Spalte A kopieren - nur bei der 1. Datei
                Set rngCopy = .Range(.Cells(Zeile1_C, 1), .Cells(lngZeile, 1))
                wksZiel.Cells(Zeile1_E, lngSpalte).Resize(rngCopy.Rows.Count, 1).Value =  _
rngCopy.Value
            End If
            'Werte in Spalte B kopieren
            Set rngCopy = .Range(.Cells(Zeile1_C, 2), .Cells(lngZeile, 2))
            lngSpalte = lngSpalte + 1
            wksZiel.Cells(Zeile1_E, lngSpalte).Resize(rngCopy.Rows.Count, 1).Value = rngCopy. _
Value
       End With
        
       wb.Close savechanges:=False
       strDatnam = Dir
    Loop
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Makro zum automatischen kopieren fehlerhaft"