Zwei Spalten vergleichen, wenn ähnlich Wunschwert eintragen.

Hallo zusammen,

ich habe ein Makro geschrieben, dass die Spalte D im Tabellenblatt "Vereine" mit der Spalte A im Tabellenblatt "Suche" vergleicht.
Bei Gleichheit oder "Treffer" trägt er im Tabellenblatt in Spalte B (0, -2) ein Sortierwort ein, aktuell "Pokalsieger".

Problem: Es funktioniert leider nur, wenn die Werte aus Spalte D Blatt "Verein" und Spalte A Blatt "Suche" genau identisch sind.
Beispiel: Nur wenn "Bayern München" in "Suche" eingetragen wird, klappt der Vergleich und es wird im Blatt Verein in Spalte B das Wort "Pokalsieger" eingetragen.

Ziel: Wie muss ich meinen Code anpassen, damit der Abgleich zwischen den Spalten nicht "gleich" iSv "identisch" ist, sondern "enthält"?
Beispiel: Wenn ich "Bayern" eintrage in Spalte B in Blatt "Suche", hätte ich gerne, dass er auch dann in Blatt "Verein" in Spalte B das Sortierwort "Pokalsieger" einträgt.
Sprich: Wenn ich z.B. "Bayern", "Leverkusen" und "Schalke" eingebe, hätte ich gerne, dass er an die entsprechende Stelle im Blatt "Verein" das Sortierwort einträgt.

Eine Beispieldatei habe ich angefügt.
https://www.herber.de/bbs/user/164263.xlsm
Anbei mein Code:

Private Sub Pokalsieger()
Dim rngTab1, rngTab2 As Range
Dim nichtGefunden As Boolean

For Each rngTab1 In Worksheets("Vereine").Range("D2:D2000")
nichtGefunden = True
If Not rngTab1 = "" Then
For Each rngTab2 In Worksheets("Suche").Range("A2:A300")
If Not rngTab2 = "" Then
If rngTab1 = rngTab2 Then
rngTab1.Offset(0, -2) = "Pokalsieger"
Exit For
End If
Else
Exit For
End If
Next rngTab2
If Not rngTab1 = rngTab2 Then rngTab1.Offset(0, -2) = "x"
Else
Exit For
End If
Next rngTab1
End Sub

Liebe Grüße!
John

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Pokalsieger() Dim zVerein As Range Dim zSuche As Range For Each zSuche In Worksheets("Suche").Range("A:A").SpecialCells(xlCellTypeConstants, 2) Set zVerein = Worksheets("Vereine").Range("D:D").Find(zSuche.Value, LookAt:=xlPart, MatchCase:=False) If zVerein Is Nothing Then 'nichts wurde gefunden zVerein.Offset(0, -2) = "x" Else zVerein.Offset(0, -2) = "Pokalsieger" End If Next End Sub

Sub Unit() Dim Searchers As Variant, Winners As Variant, Results As Variant Dim P As Long, S As Long With Worksheets("Suche") Searchers = .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With Worksheets("Vereine") Winners = .Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row).Value ReDim Results(LBound(Winners) To UBound(Winners), 1 To 1) For P = LBound(Results) To UBound(Results) Results(P, 1) = "x" Next For S = LBound(Searchers) To UBound(Searchers) If Searchers(S, 1) > "" Then For P = LBound(Winners) To UBound(Winners) If InStr(Winners(P, 1), CStr(Searchers(S, 1))) Then Results(P, 1) = "Pokalsieger" Next End If Next .Range("B2:B" & .Cells(Rows.Count, 4).End(xlUp).Row) = Results End With End Sub

Beliebteste Forumthreads (12 Monate)

Zwei Spalten vergleichen, wenn ähnlich Wunschwert eintragen.

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread