Kopieren und Anfügen von Zeilen
11.11.2020 15:05:29
Zeilen
ich bin neu hier, ich hoffe, es tut keinen Abbruch.
Ich habe folgendes Problem: Ich möchte Zeilen aus mehreren Exceltabellen in einer Tabelle, Arbeitsblatt kopieren und die weiteren in die jeweils nächsten Zeile kopieren. Bei diesem Code klappt es nicht, die Daten in Zeile 4 werden immer wieder überschrieben, so dass nur die Werte der letzten Tabelle kopiert werden.
Ich nutze folgenden Code:
Sub Werte_2016_kopieren()
Dim Zieltabelle As Object
Dim Quelle As Object
Dim Pfad As String
Dim Datei As String
Dim letzteReiheZiel As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Zieltabelle = ActiveWorkbook
'Alle Dateien im Verzeichnis öffnen und Schreibschutz aufheben, Worksheet Werte 2016_acc _
aktivieren, Daten kopieren nach "Testdatei_Modul.xlsm" und Dateien schließen
Pfad = InputBox("Pfad eingeben", "Pfad")
Datei = Dir(CStr(Pfad & "*.xl*"))
Do While Datei ""
Set Quelle = Workbooks.Open(Pfad & Datei, False, True)
ThisWorkbook.Unprotect Password:="Blank"
Worksheets("Grunddaten").Visible = xlSheetVisible
Worksheets("Grunddaten").Unprotect Password:="Blank"
Worksheets("Werte Haushalte").Visible = xlSheetVisible
Worksheets("Werte Haushalte").Unprotect Password:="Blank"
Worksheets(" Vermögen und Afa").Visible = xlSheetVisible
Worksheets(" Vermögen und Afa").Unprotect Password:="Blank"
Worksheets("Investitionsrückstände").Visible = xlSheetVisible
Worksheets("Investitionsrückstände").Unprotect Password:="Blank"
Sheets("Investitionsrückstände").Select
ActiveWorkbook.Unprotect Password:="Blank"
Sheets("Investitionsrückstände").Select
Worksheets("Werte 2016_acc").Visible = True
Worksheets("Werte 2016_acc").Select
Range("A4:du4").Copy
Zieltabelle.Worksheets("Werte 2016_acc").Activate
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Quelle.Close SaveChanges:=False
Datei = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Da ich echt verzweifelt bin, freue ich mich über Hilfe.