Daten von Mappe1 nach Mappe2 kopieren

Hallo Profis,
auf der Suche nach meiner Lösung für meinen Fehler bin ich leider nicht fündig geworden. Ich würde mich freuen wenn man mir helfen kann :)
Folgendes Problem:
Mappe1 Tabelle1 (Protokoll):
Hier werden Daten in den Spalten A:K geschrieben. Spalte A enthält eine eindeutige Seriennummer welche in 10 Zeilen geschrieben wird. Die entsprechenden Werte werden in B:K geschrieben.
Mappe2 Tabelle1 (Archiv):
Hier sollen die neuen Seriennummern mit Daten in den gleichen Spalten/Zeilen reingeschrieben werden, jedoch nach dem letzten Eintrag.
Ich habe es für die Mappe1 geschafft, die Einträge in die letzte Zeile zu bekommen. Jedoch habe ich es nicht geschafft, die neuen Seriennummern zu suchen und einzufügen.
Anbei das Makro:


Sub test()
Call aktu_aus       'Unterprogramm Bildschirmaktualisierung aus
Sheets("Tabelle1").Range("A1:K2000").Copy           'Von der Quelle zu..
Workbooks.Open Filename:="C:MeinPfad\Mappe2.xlsm"
Sheets("Tabelle1").Cells(Sheets("Tabelle1").Rows.Count, 1).End(xlUp).Offset(1, 0).Select    ' _
Ziel  _
einfügen
ActiveSheet.Paste
'Speichert die Datei wieder als XLSM-File und überschreibt die bereits vorhandene Version
ActiveWorkbook.SaveAs Filename:= _
"C:\MeinPfad\Mappe2.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, Local:=True
Windows("Mappe1.xlsm").Activate
Sheets("Tabelle1").Range("A1:K2000").ClearContents
Call aktu_an        'Unterprogramm Bildschirmaktualisierung an
End Sub

Ich würde mich sehr freuen, wenn mir hierzu jemand helfen kann.
Vielen Dank im voraus.
Grüße
Micha

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Start() Dim ExWB As Workbook, ExWS As Worksheet, rngTemp As Range, rng As Range Dim sPath$, sNr$ Dim NextRow&, MaxRow& On Error GoTo ErrorHandler sPath = ThisWorkbook.Path & IIf(Right$(ThisWorkbook.Path, 1) "\", "\", "") sPath = sPath & "Archivauswertung.xlsm" Call Events_(False) Set ExWB = Workbooks.Open(sPath) Set ExWS = ExWB.Sheets("MP12") With MP12 MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row sNr = ExWS.UsedRange.Columns(1).Address(1, 1, xlR1C1, True, .Cells(1, .Columns.Count)) With .Cells(1, .Columns.Count).Resize(MaxRow) .FormulaR1C1 = "=IF(CountIf(" & sNr & ",RC1)=0,True,1)" Set rngTemp = FindFehlende(.Cells) End With End With If Not rngTemp Is Nothing Then With ExWS For Each rng In rngTemp.Areas NextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 rng.EntireRow.Columns(1).Resize(, 15).Copy .Cells(NextRow, 1) Next End With ExWB.Save End If ErrorHandler: On Error Resume Next ExWB.Close False MP12.Columns(MP12.Columns.Count).Delete Call Events_(True) If Err.Number 0 Then MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number Else MsgBox "Daten wurden übertragen!", vbInformation End If End Sub

Beliebteste Forumthreads (12 Monate)

Daten von Mappe1 nach Mappe2 kopieren

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread