Nach 3 Kriterien mittels Makro suchen

Hallo liebes Forum,
Ich habe gerade versucht, eine Suchabfrage innerhalb von Excel per VBA umzusetzen und bin leider gescheitert, weshalb ich um eure Unterstützung fragen wollte.
Zur Problemstellung:
In meine ersten Tabellenblatt (Blatt1") sind die Spalten A, D, I und Q relevant. Im zweiten Tabellenblatt (Blatt2") sind die Spalten B, D und E relevant.
Es soll nun mittels VBA eine "Verbindung" zwischen den beiden Tabellenblättern hergestellt werden.
Die gesamte Spalte D (Blatt 1) soll nach dem Wert der Zelle B2 (Blatt 2) durchsucht werden UND die gesamte Spalte Q (Blatt 1) soll nach dem Wert der Zelle E2 (Blatt 2) durchsucht werden UND ....
Die Dritte UND-Bedingung sollte folgendermaßen aussehen:
Suchkriterium ist der erste Teil des Strings in Zelle D2 (Blatt 2) bis zum ersten Leerzeichen. Suchbereich soll allerdings auch immer nur der erste Teil des Strings allerdings in jeder Zelle der Spalte I (Blatt 1) sein.
Diese Suche soll auf alle Zeilen innerhalb von Blatt 2 angewendet werden.
Wenn eine Zeile gefunden wird, welche alle drei Bedingungen erfüllt, sollte der Wert aus der Zelle A? (Blatt 1) in die entsprechende Zelle (Q?) im Blatt 2 kopiert werden. Wenn von Excel mehrere mögliche "Werte" gefunden werden, wäre schön, wenn all diese Werte nebeneinander, beginnend in Spalte Q, ausgegeben werden könnten.
Ich hoffe meine Problemstellung ist halbwegs verständlich. Im Prinzip solle es so etwas Ähnliches wie ein 3-facher SVerweis, allerdings mit 2 verschiedenen Tabellenblättern, sein.
Ich hoffe auf eure Unterstützung.
Vielen Dank,
LG

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit '13.5.17 vergleiche Blatt1 mit Blatt2 Dim rfind As Object, SuName1 Dim sFind As Object, SuName2 Dim tFind As Object, Strg3 Sub Vergleiche_Tabellen() Dim Tb2 As Worksheet, Txt As String Dim Adr1 As String, z, s As Integer Set Tb2 = Worksheets("Blatt2") On Error Resume Next With Worksheets("Blatt1") 'alte Liste löschen (Spalten selbst festlegen) Tb2.Columns("O:Q").ClearContents SuName1 = Tb2.Range("B2") SuName2 = Tb2.Range("E2") Strg3 = Tb2.Range("D2") 'String bis " " Strg3 = Trim(Left(Strg3, InStr(Strg3, " "))) 'Prüfen ob alle 3 Suchnamen in D, I, Q vorkommen Set sFind = .Columns("Q").Find(What:=SuName2, After:=.Range("Q1"), _ LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext) If sFind Is Nothing Then MsgBox SuName2 & " Suchbegriff 2 Zelle E2 nicht gefunden": Exit _ Sub Set tFind = .Columns("I").Find(What:=Strg3, After:=.Range("I1"), _ LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext) If tFind Is Nothing Then MsgBox Strg3 & " Suchbegriff 3 Zelle D2 nicht gefunden": Exit _ Sub Set rfind = .Columns("D").Find(What:=SuName1, After:=.Range("D1"), _ LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext) If rfind Is Nothing Then MsgBox SuName1 & " Suchbegriff 1 Zelle B2 nicht gefunden": Exit _ Sub Adr1 = rfind.Address s = 1 '1.ßPalte "O" '** wahlweise z=2 oder z = 1. Find Zeile z = rfind.Row 'aktive Zeile, Spalte 1 = "O" 'z = 2 '1. Zeile zum auflisten in Blatt 2 Do 'Do Loop für alle Werte Txt = .Cells(rfind.Row, "I") If InStr(Txt, " ") Then Txt = Trim(Left(Txt, InStr(Txt, " "))) 'Spalte Q und String I prüfen If .Cells(rfind.Row, "Q") = SuName2 And Txt = Strg3 Then Tb2.Range("Q" & z).Cells(1, s) = .Cells(rfind.Row, "A") s = s + 1 'next Spalte neben "O" End If Set rfind = .Columns("D").FindNext(After:=rfind) If rfind Is Nothing Then Exit Do Loop Until rfind.Address = Adr1 End With End Sub

Sub Suchen_Vergleichen() Dim strSuchbegriff1 As String, strSuchbegriff2 As String, strTeil As String Dim raFundzelle As Range, raSuchbereich As Range Dim loLetzte As Long, loFundzeile As Long, loSpalte As Long Dim boGefunden As Boolean With Worksheets("Tabelle2") strSuchbegriff1 = .Range("B2") strSuchbegriff2 = .Range("E2") loSpalte = 17 On Error Resume Next If IsError(Left(.Range("D2"), WorksheetFunction.Find(" ", .Range("D2")) - 1)) Then strTeil = .Range("D2").Value Else strTeil = Left(.Range("D2"), WorksheetFunction.Find(" ", .Range("D2")) - 1) End If End With With Worksheets("Tabelle1") loLetzte = .Cells(.Rows.Count, 4).End(xlUp).Row Set raSuchbereich = .Range(.Cells(1, 4), .Cells(loLetzte, 4)) End With With raSuchbereich Set raFundzelle = .Find(strSuchbegriff1, LookAt:=xlWhole, LookIn:=xlValues) loFundzeile = raFundzelle.Row If Not raFundzelle Is Nothing Then firstAddress = raFundzelle.Address Do If raFundzelle.Offset(0, 13) = strSuchbegriff2 And _ raFundzelle.Offset(0, 5) = strTeil Then boGefunden = True Worksheets("Tabelle2").Cells(loFundzeile, loSpalte) = _ raFundzelle.Offset(0, -3).Value loSpalte = loSpalte + 1 End If Set raFundzelle = .FindNext(raFundzelle) Loop While Not raFundzelle Is Nothing And raFundzelle.Address firstAddress If Not boGefunden Then MsgBox "Keine Übereinstimmungen gefunden" Else MsgBox "Suchbegriff " & strSuchbegriff1 & " nicht vorhanden." End If End With On Error GoTo 0 End Sub

Hallo Mike,
ich verstehe nicht, warum die Anforderungen an das Makro immer nur scheibchenweise mitgeteilt werden (aber da bist du nicht der Einzige). Es wäre einfach besser, von Anfang an genau zu beschreiben, was das Makro im Einzelnen so alles machen soll. Dann noch eine Beispielmappe mit ein paar Daten dazu packen (die in ihrer Struktur deinem Original entsprechen) und das Ganze hat Hand und Fuß.
Dann noch eine Anmerkung: Du hast in einem der Beiträge geschrieben, dass du die Ergebnisse der Suche im Blatt 2 in der Zeile der Fundstelle haben möchtest.
Fundstelle Blatt 1 Zelle I24 Ergenis nach Blatt 2 Zelle Q25
Wenn ich mir jetzt ansehe, dass du in Blatt 2 wohl diverse Suchbegriffe in einer Liste untereinander hast die das Makro durchlaufen soll, dann macht das meiner Meinung nach wohl kaum Sinn die Ergebnisse der Suche im Blatt 2 in die Fundzeile von Blatt 1 zu schreiben.
Das hätte ja folgenden Effekt:
Blatt 2 in Zeile 5 stehen die Suchbegriffe
die werden in Blatt 1 in der Zeile 25 gefunden und dann in Blatt 2 in der Zelle Q25 ausgegeben
Dann hat ja die Ausgabe überhaupt nichts mehr mit den Suchbegriffen in Blatt 2 zu tun und lässt sich auch nicht mehr zu diesen zuordnen.

Option Explicit
Sub Suchen_Vergleichen()
Dim strSuchbegriff1 As String, strSuchbegriff2 As String, strTeil As String, firstAddress As  _
String
Dim raFundzelle As Range, raSuchbereich As Range
Dim loLetzte1 As Long, loFundzeile As Long, loSpalte As Long, loLetzte2 As Long, i As Long
Dim boGefunden As Boolean
loLetzte2 = Worksheets("Tabelle2").Cells(Rows.Count, 2).End(xlUp).Row
loSpalte = 17
For i = 2 To loLetzte2
With Worksheets("Tabelle2")
strSuchbegriff1 = .Cells(i, 2)
strSuchbegriff2 = .Cells(i, 5)
On Error Resume Next
If IsError(Left(.Cells(i, 4), WorksheetFunction.Find(" ", .Cells(i, 4)) - 1)) Then
strTeil = .Cells(i, 4).Value
Else
strTeil = Left(.Cells(i, 4), WorksheetFunction.Find(" ", .Cells(i, 4)) - 1)
End If
End With
With Worksheets("Tabelle1")
loLetzte1 = .Cells(.Rows.Count, 4).End(xlUp).Row
Set raSuchbereich = .Range(.Cells(1, 4), .Cells(loLetzte1, 4))
End With
With raSuchbereich
Set raFundzelle = .Find(strSuchbegriff1, LookAt:=xlWhole, LookIn:=xlValues)
loFundzeile = raFundzelle.Row
If Not raFundzelle Is Nothing Then
firstAddress = raFundzelle.Address
Do
If raFundzelle.Offset(0, 13) = strSuchbegriff2 And _
raFundzelle.Offset(0, 5) Like "*" & strTeil & "*" Then
boGefunden = True
Worksheets("Tabelle2").Cells(i, loSpalte) = _
raFundzelle.Offset(0, -3).Value
loSpalte = loSpalte + 1
End If
Set raFundzelle = .FindNext(raFundzelle)
Loop While Not raFundzelle Is Nothing And raFundzelle.Address  firstAddress
loSpalte = 17
If Not boGefunden Then MsgBox "Keine Übereinstimmungen gefunden"
Else
MsgBox "Suchbegriff " & strSuchbegriff1 & " nicht vorhanden."
End If
End With
Next i
On Error GoTo 0
End Sub

Teste das hier mal.
Gruß Werner

Beliebteste Forumthreads (12 Monate)

Nach 3 Kriterien mittels Makro suchen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Nach 3 Kriterien mittels Makro suchen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread