Hallo, komme mal wieder mit einer Frage. Ich möchte Werte aus einer Datei/Tabelle in eine neue Tabelle kopieren. Ich wähle in den Spalte C und D die zugehörigkeiten zu den einzelnen Datensätzen in der neuen Datei aus. Mein Problem ist dabei, das der Inhalt erfasst, aber nicht in die neue Datei kopiert wird sonder in der Quelldatei im Anschluss an bereits bestehende Werte angefügt wird. Meine Vermutung ist, dass der Fehler im folgenden Codeabschnitt ist.
Und hier mein zusammengetragener Code. (Wahrscheinlich laienhaft aufgebaut). Kann mir trotz allem jemand hier weiter helfen?
Gruß Josef
Visual Basic:
' Wenn eine Übereinstimmung gefunden wurde, kopiere die Daten aus Spalte A
If matchFound Then
wsTarget.Cells(lastRowTarget, 1).Value = wsSource.Cells(i, 1).Value
Debug.Print "Kopiert Wert: " & wsSource.Cells(i, 1).Value & " nach Zeile: " & lastRowTarget & " in Zieldatei"
lastRowTarget = lastRowTarget + 1
End IfUnd hier mein zusammengetragener Code. (Wahrscheinlich laienhaft aufgebaut). Kann mir trotz allem jemand hier weiter helfen?
Gruß Josef
Visual Basic:
Sub CopyDataWithCondition2()
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRowSource As Long
Dim lastRowTarget As Long
Dim i As Long
Dim j As Long
Dim matchFound As Boolean
' Pfade zu den Dateien (Anpassen der Pfade notwendig)
Dim sourceFilePath As String
Dim targetFilePath As String
sourceFilePath = "C:\Users\Besitzer\Desktop\Vergleich1.xlsm"
targetFilePath = "C:\Users\Besitzer\Desktop\Vergleich2.xlsx"
On Error GoTo ErrHandler
' Öffne die Quelldatei
Set wbSource = Workbooks.Open(sourceFilePath)
If wbSource Is Nothing Then
MsgBox "Fehler beim Öffnen der Quelldatei.", vbCritical
Exit Sub
End If
Set wsSource = wbSource.Sheets("Tabelle1") ' Anpassen des Blattnamens falls notwendig
If wsSource Is Nothing Then
MsgBox "Fehler beim Öffnen des Arbeitsblatts in der Quelldatei.", vbCritical
Exit Sub
End If
' Öffne die Zieldatei
Set wbTarget = Workbooks.Open(targetFilePath)
If wbTarget Is Nothing Then
MsgBox "Fehler beim Öffnen der Zieldatei.", vbCritical
Exit Sub
End If
Set wsTarget = wbTarget.Sheets("Tabelle1") ' Anpassen des Blattnamens falls notwendig
If wsTarget Is Nothing Then
MsgBox "Fehler beim Öffnen des Arbeitsblatts in der Zieldatei.", vbCritical
Exit Sub
End If
' Letzte belegte Zeile in der Quelldatei in Spalte A
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
Debug.Print "Letzte Zeile in der Quelldatei: " & lastRowSource
' Letzte belegte Zeile in der Zieldatei in Spalte A
lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
Debug.Print "Nächste freie Zeile in der Zieldatei: " & lastRowTarget
' Durchlaufen der Zeilen in der Quelldatei
For i = 2 To lastRowSource ' Starten bei Zeile 2, falls Zeile 1 Überschriften enthält
matchFound = False
' Durchlaufen der Zeilen in der Zieldatei, um Übereinstimmung in Spalte C und D zu finden
For j = 2 To wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row ' Starten bei Zeile 2, falls Zeile 1 Überschriften enthält
If wsSource.Cells(i, 3).Value = wsTarget.Cells(j, 3).Value And wsSource.Cells(i, 4).Value = wsTarget.Cells(j, 4).Value Then
matchFound = True
Exit For
End If
Next j
' Wenn eine Übereinstimmung gefunden wurde, kopiere die Daten aus Spalte A
If matchFound Then
wsTarget.Cells(lastRowTarget, 1).Value = wsSource.Cells(i, 1).Value
Debug.Print "Kopiert Wert: " & wsSource.Cells(i, 1).Value & " nach Zeile: " & lastRowTarget & " in Zieldatei"
lastRowTarget = lastRowTarget + 1
End If
Next i
' Bestätigungsmeldung anzeigen
MsgBox "Daten erfolgreich kopiert.", vbInformation
' Schließen der Arbeitsmappen
' wbSource.Close SaveChanges:=False
' wbTarget.Close SaveChanges:=True
Exit Sub
ErrHandler:
MsgBox "Fehler: " & Err.Description, vbCritical
On Error Resume Next
If Not wbSource Is Nothing Then wbSource.Close SaveChanges:=False
If Not wbTarget Is Nothing Then wbTarget.Close SaveChanges:=False
End Sub
