Prüfbedingungen Spaltenvergleich Ausgabe

Sub Vergleich() Dim rngQuelle As Range Dim rngZiel As Range With ThisWorkbook.Sheets("Sheet1") For Each rngZiel In .Range("H1:H" & .Cells(.Rows.Count, 2).End(xlUp).Row) On Error Resume Next Set rngQuelle = ThisWorkbook.Sheets("Sheet2").Range("A:K").Find(What:=rngZiel) On Error GoTo 0 If Not rngQuelle Is Nothing Then rngQuelle.Offset(0, 4).Resize(1, 1).Copy rngZiel.Offset(0, 1).Resize(1, 1).PasteSpecial Paste:=xlPasteValues End If Next 'rngZiel End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
anbei ein Code von mir der eine machbare Lösung zeigt. Er muss aber noch mal im Kopier Modus geaendert werden.
Einige Dinge sind mir noch unklar? Widersprüchlich?
Ich habe verstanden das z.B. Text Sonnenfinsternis in Sheet1 in Spalte I steht, bei Sheet 2 aber in G
Unklar ist mir der Suchlauf: - Sheets("Sheet2").Range("A:K"), denn Spalte K geht über Spalte G hinaus!
Darunter kommt die Kopie Anweisung: - rngQuelle.Offset(0, 4).Resize(1, 1).Copy
Das verstehe ich nicht so ganz, denn wenn ich von A:K suche, wie will ich mit Offset(0,4) die Spalte G treffen?
Der gefundene Wert müsste dann ja -immer in der Spalte C stehen-, sonst kann Offset(0,4) nicht stimmen!!
Da ist für mich etwas unklar. Bitte selbst prüfen.
Weiter wird kopiert mit Code: - rngZiel.Offset(0, 1).Resize(1, 1).PasteSpecial. Auf Resize(1,1) kann man ganz verzichten.
Stutzig macht mich Offset(0, 1). denn wenn ich das richtig sehe stehe ich mit rngZiel in Spalte "H"! das heisst, ich kopiere
jetzt in die Spalte I. - Ist das richtig? Ich denke das in Spalte I Werte zum vergleichen stehen. Die werden mit dem Code überschrieben. Ich bitte den Teil selbst noch einmal zu prüfen.
Ich hoffe das meine gedankliche Anregung aber grundsaetzlich weiter hilft. Würde mich freuen.
mfg Piet



Sub Vergleich()
Dim rngQuelle As Range
Dim rngZiel As Range
Dim Sht2 As Object
Dim QuellTxt As String
Dim ZielTxt As String
Set Sht2 = ThisWorkbook.Sheets("Sheet2")
With ThisWorkbook.Sheets("Sheet1")
For Each rngZiel In .Range("H1:H" & .Cells(.Rows.Count, 2).End(xlUp).Row)
Set rngQuelle = Sht2.Range("A:K").Find(What:=rngZiel)
If Not rngQuelle Is Nothing Then
'Quell + Ziel Texte zum vergleicenh laden
ZielTxt = rngZiel.Offset(0, 1).Value        'Spalte I
QuellTxt = Sht2.Cells(rngQuelle.Row, "G")   'Spalte G
'nur kopieren wenn Texte ganz oder teilweise übereinstimmen
If InStr(QuellTxt, ZielTxt) Or InStr(ZielTxt, QuellTxt) Then
rngQuelle.Offset(0, 4).Resize(1, 1).Copy
rngZiel.Offset(0, 1).Resize(1, 1).PasteSpecial Paste:=xlPasteValues
End If
End If
Next 'rngZiel
End With
End Sub

Hallo Piet,
erstmal vielen Dank für deine Antwort samt Code!
Ich habe mit deinem Code etwas rumgespielt, leider passiert nichts. Diese angesprochene Offset Geschichte verstehe ich leider auch nicht richtig: rngQuelle.Offset(0, 4).Copy Das heißt doch dass er die 4. Spalte rechts von Spalte "A" kopiert? In Spalte D stehen die zu kopierenden Codes wie ich es am Beispiel versucht habe zu verdeutlichen. Also Spalte H (Sheet1) soll zunächst mit Spalte G(Sheet2) abgeglichen werden (dreistelligen Zahlencodes). Gleichzeitig soll der zu Spalte (H) gehörende Langtext (befindet sich in Spalte I) mit Spalte G (Sheet2) verglichen werden (wiegesagt auch ungefähre Übereinstimmungen sollen als wahr angesehen werden). Wenn Zahl und Text übereinstimmt, soll der zu den Zahlencodes in Sheet2 gehörende Textcode (dreistellig, siehe Beispiel oben) aus Spalte D (Sheet2) in Spalte (J, also neben den Langtext in Sheet1) hineinkopiert werden =).
Wäre sehr sehr nett, wenn du mir sagen könntest wo der Fehler noch liegt, was ich ggf. noch anpassen muss.
LG

Option Explicit 'neuer Code nach letzten Angaben 'QuellText aus Sheet2 Spalte D kopieren nach Sheet1 Spalte j Sub Vergleich_Neu() Dim rngQuelle As Range Dim rngZiel As Range Dim Sht2 As Object Dim QuellTxt As String Dim ZielTxt As String Set Sht2 = ThisWorkbook.Sheets("Sheet2") With ThisWorkbook.Sheets("Sheet1") For Each rngZiel In .Range("H1:H" & .Cells(.Rows.Count, 2).End(xlUp).Row) Set rngQuelle = Sht2.Range("G:G").Find(What:=rngZiel, LookAt:=xlWhole) If Not rngQuelle Is Nothing Then 'Quell + Ziel Texte zum vergleicenh laden ZielTxt = rngZiel.Offset(0, 1).Value 'Spalte I (Sheet1) QuellTxt = Sht2.Cells(rngQuelle.Row, "D") 'Spalte D (Sheet2) 'nur kopieren wenn Texte ganz oder teilweise übereinstimmen If InStr(QuellTxt, ZielTxt) Or InStr(ZielTxt, QuellTxt) Then 'kopiere QuellTxt in Spalte J (Sheet1) rngZiel.Offset(0, -1) = QuellTxt End If End If Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Prüfbedingungen Spaltenvergleich Ausgabe

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread