Ich habe einen VBA Code der mir Spalten abgleicht und dann aus z.B. Spalte „A“ die Werte in eine neue Datei kopiert. Mein Problem dabei ist: Es wird die komplette Zeile und nicht nur der Wert in Spalte „A“ kopiert, was aber nicht sein soll. Kann mir da jemand weiter helfe? Der Code sieht wie folgt aus:
Private Sub CommandButton1_Click()
''Sub kopieren()
‚‘
''Workbooks(„Vergleich1.xlsm“).Worksheets(„Tabelle1“).Range(„A2:A12“).Copy _
''Workbooks(„Vergleich2.xlsx“).Worksheets(„Tabelle1“).Range(„A2“)
''End Sub
‚‘ Sub CopyDataWithCondition22()
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 F zu finden.
' Spalten müssen eindeutige Unterscheidungsmerkmale haben, doppelte Werte werden ansonsten als ein Wert erkannt.
For j = 2 To lastRowTarget - 1 ' 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, 6).Value = wsTarget.Cells(j, 6).Value Then
matchFound = True
Exit For
End If
Next j
' Wenn Übereinstimmung gefunden wurde, kopiere die Daten aus Spalte A
If matchFound = False 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