AW: Bei Finden eines Suchbegriffs Übertrag bestimmter Zellen
MCO
Moin, Martin!
Ich hoffe, dass ich dein Anliegen richtig umgesetzt habe.
Allerdings hab ich mir nicht die Mühe gemacht, deinen Code zu modifizieren sondern bin neu angefangen.
Probier es mal aus:
Sub Übertragen()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim wert As Range, werte As Range, gefunden As Range
Dim str_werte1 As String, str_werte2 As String
Dim sp_array As Variant
Dim i As Integer, lz As Long
' Arbeitsblätter zuweisen
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
' Werte aus Spalte C des zweiten Sheets abrufen
Set werte = sh2.Range("C:C").SpecialCells(xlCellTypeConstants, xlNumbers)
' Erste Vergleichsschleife (sh2 -> sh1)
For Each wert In werte
' Suche den Wert in Spalte C von sh1
Set gefunden = sh1.Range("C:C").Find(what:=wert, LookIn:=xlValues, LookAt:=xlWhole)
If Not gefunden Is Nothing Then ' Falls Wert gefunden wurde
' Erstellen von Vergleichsstrings für geänderte Datensätze
str_werte1 = WorksheetFunction.Concat(sh1.Range("D" & gefunden.Row & ":H" & gefunden.Row), sh1.Cells(gefunden.Row, "B"))
str_werte2 = WorksheetFunction.Concat(sh2.Range("D" & wert.Row & ":H" & wert.Row), sh2.Cells(wert.Row, "B"))
If str_werte1 <> str_werte2 Then ' Unterschiedliche Inhalte?
sh2.Cells(wert.Row, "N").Value = "veränderter Datensatz"
End If
' Datenübernahme
sp_array = Array(2, 4, 5, 6, 7, 8) ' zu übertragende Spalten
For i = LBound(sp_array) To UBound(sp_array)
sh1.Cells(gefunden.Row, sp_array(i)).Value = sh2.Cells(wert.Row, sp_array(i)).Value
Next i
Else
' Markiere nicht gefundene Werte rot
wert.Interior.ColorIndex = 3
End If
Next wert
' Umgedrehte Suche (sh1 -> sh2)
Set werte = sh1.Range("C:C").SpecialCells(xlCellTypeConstants, xlNumbers)
For Each wert In werte
Set gefunden = sh2.Range("C:C").Find(what:=wert, LookIn:=xlValues, LookAt:=xlWhole)
If gefunden Is Nothing Then ' Falls nicht in sh2 gefunden
lz = sh2.Cells(Rows.Count, "C").End(xlUp).Row ' Letzte verwendete Zeile
sp_array = Array(2, 3, 4, 5, 6, 7, 8) ' zu übertragende Spalten
For i = LBound(sp_array) To UBound(sp_array)
sh2.Cells(lz + 1, sp_array(i)).Value = sh1.Cells(wert.Row, sp_array(i)).Value
Next i
sh2.Cells(lz + 1, "N").Value = "veränderter Datensatz"
End If
Next wert
End Sub
Gruß, MCO