|
Hallo liebe Helferinnen und Helfer,
ich habe folgendes Problem. Und zwar muss ich aus mehreren Excel-Dateien bestimmte Zeilen rausnehmen und in einer Tabelle untereinander ordnen. Das Problem ist jedoch, dass die Daten sich gegenseitig ständig überschreiben.
Momentan funktioniert meine Lösung so:
- Makro öffnet die erste Datei im Ordner
- Springt zum zweiten Registerblatt
- Kopiert die gewünschte Zeile/Zeilen
- Fügt sie in die neue Datei ein und schließt die gerade geöffnete Datei
- Die nächste Datei im Ordner wird geöffnet
- Zeile im zweiten Registerblatt wird kopiert
- *HIER IST DER FEHLER* Die zuvor eingefügten Daten werden mit den neuen Daten überschrieben anstatt unten drangehängt
Ich weiß zwar, dass man dieses durch Insert Shift:=xlDown verhindern kann, da ich aber die Daten transponiert einfügen muss, benötige ich auch gleichzeitig PasteSpecial. In Kombination funktioniert das aber irgendwie nicht.
Hier ist der Code, vielen Dank, für eure Arbeit hier :)
Sub DatenEinfügen()
Dim MySheet As Worksheet ' aktuelles Arbeitsblatt
Dim strPath As String ' Dateipfad zum Auslesen der Dateien
Dim strFile As String ' Quelldatei
Dim wkbInput, Messbericht As Workbook ' Quell-Arbeitsmappe
Dim wksInput As Worksheet ' Quell-Registerblatt
Dim lngTargetRow As Long ' Zeilenzähler für die Bewertungsinformationen
Dim lRow As Long ' Schleifenzähler
Dim lCol As Long ' Schleifenzähler
Dim i As Integer
Application.DisplayAlerts = False
Delta = 0
Set MySheet = ActiveSheet
Set Messbericht = ActiveWorkbook
strPath = ActiveWorkbook.Path
'-------------------------------------'
' Verzeichnis durchgehen und alle Dateien auslesen
'-------------------------------------'
strFile = Dir(strPath & "\*.xlsx")
Do While strFile <> "" ' Schleife beginnen
If strFile = ActiveWorkbook.Name Then
'-------------------------------------'
' Zieldatei natürlich übergehen
'-------------------------------------'
Else
'-------------------------------------'
' Quelldatei öffnen
' und 1. Registerblatt auswählen
'-------------------------------------'
Set wkbInput = Application.Workbooks.Open(strPath & "\" & strFile) 'Quelldatei öffen
i = 2
Do Until wkbInput.Worksheets(i).Name = "1"
Set wksInput = wkbInput.Worksheets(i) 'erstes tabellenblatt öffnen
'-------------------------------------'
' Daten auslesen und in Auswertung kopieren
'-------------------------------------'
wksInput.Activate
wksInput.Range("=L7:AQ7").Select
Selection.Copy
Messbericht.Activate
'MySheet.Activate
Worksheets(i).Activate
Worksheets(i).Range("=A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
i = i + 1
Loop
'-------------------------------------'
' Datei schließen
'-------------------------------------'
wkbInput.Close
Set wkbInput = Nothing
End If
strFile = Dir ' Nächsten Eintrag abrufen
Loop
End Sub
|