Nach 3 Kriterien mittels Makro suchen

Mike · 2017-05-11T15:07:36+00:00

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

Hallo Mike
anbei mal ein Makro Code von mir, bitte in ein normales Modul kopieren.
Zum auflisten kann man waehlen ob das Ergebnis im Blatt 2 in Zeile z=2 oder in der Find Zeile stehen soll. Der Teil für Zeile 2 ist jetzt deaktiviert s. 'z = 2 ; man muss nur das ' entfernen
Der Code listet alles ab Spalte O nach rechts auf. Ich hoffe das hilft dir weiter.
mfg Piet


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

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

Nach 3 Kriterien mittels Makro suchen

Forumthread: Nach 3 Kriterien mittels Makro suchen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial