VBA - Vergleichen und Kopieren
04.08.2015 13:06:45
Michael
ich verzweifle hier gerade an einem Code.
Problemstellung:
Ich möchte aus einer Quelldatei Werte in bestimmten Zellen aus einer Zeile in eine Zieldatei kopieren. Das funktioniert schonmal ganz gut. Ich brauche aber eine Anpassung des Codes dahingehend das erst geprüft wird ob die gleichen Werte bereits in beiden Tabellen enthalten sind. Wenn ja soll nicht kopiert werden, ansonsten nur die die noch nicht in der Zieldatei enthalten sind.
Ich habe mal die beiden Beispieldateien angehängt. So soll in der Quelldatei in der Spalte D (Nr.) auf Übereinstimmung in der Zieldatei Spalte A50 bis A64 überprüft werden. Eine Suche im Netz ergab bisher folgenden vielleicht am besten dazu passenden Code. Jedoch komme ich da ab einer bestimmten Stelle nicht mehr weiter:
Sub Import_2()
Dim wkb As Workbook
Dim wkb1 As Workbook
Dim wks As Worksheet
Dim wks1 As Worksheet
Dim rng As Range
Dim iRow As Integer
Dim i
Application.ScreenUpdating = False
On Error Resume Next
On Error GoTo 0
Set wkb = Workbooks("Quelle.xls")
Set wkb1 = ThisWorkbook
wkb1.Activate
Set wks = wkb.Worksheets("Test")
Set wks1 = wkb1.Worksheets("Import")
anz = wks.Cells(200, 4).End(xlUp).Row
' anz1 = Range? 'Von A50:A64
For z = 3 To anz1
suchwert = wks1.Cells(z, 1)
With wks.Range("a2:a" & anz)
Set c = .Find(suchwert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
For s = 2 To 11
wks.Cells(c.Row, s) = wks1.Cells(z, s)
Next
Else
For s = 1 To 11
wks.Cells(anz + 1, s) = wks1.Cells(z, s)
Next
anz = wks.Cells(200, 4).End(xlUp).Row
End If
End With
Next
Application.ScreenUpdating = True
End Sub
Ich hoffe ich konnte mein Problem ansatzweise gut erläutern. Über jede Hilfe bin ich dankbar.
Gruß
Michael
https://www.herber.de/bbs/user/99321.xlsm
https://www.herber.de/bbs/user/99322.xls