AW: Formelsuche mit 2 Suchkriterien (sverweis und mehr...)
04.11.2025 18:48:58
Erwin
Hallo Zusammen,
eigentlich wollte ich eine Formellösung, aber dann habe ich mich hier bei ChatGPT angemeldet und öfter und länger hin und her geschrieben, bis ich jetzt einen passenden Code gefunden habe.
Tabelle Arztsuche:
Private Sub Worksheet_Change(ByVal Target As Range)
' Startet automatisch, wenn sich O102 oder O104 ändert
If Not Intersect(Target, Me.Range("O102,O104")) Is Nothing Then
Call ÄrzteNachPLZ_BK_Suchen
End If
End Sub
Modul für die Suche mit mehreren Bedingungen und Kriterien:
Sub ÄrzteNachPLZ_BK_Suchen()
Dim wsSuche As Worksheet, wsDaten As Worksheet
Dim plz As String, bk As String
Dim i As Long, zeile As Long
Dim letzte As Long, j As Long
Dim treffer As Boolean, bkListe As String
Dim ArztSpalten As Variant, BKSpalten As Variant
Dim b As Long
Dim parts As Variant
Dim startCol As Long, endCol As Long, arztCol As Long
Dim anzahl As Long
' Arbeitsblätter
Set wsSuche = ThisWorkbook.Worksheets("Arztsuche")
Set wsDaten = ThisWorkbook.Worksheets("Ansprechpartner")
' Eingaben
plz = Trim(wsSuche.Range("O102").Value)
bk = Trim(wsSuche.Range("O104").Value)
' Ausgabe-Bereich löschen (nur Spalte J, ab 106)
wsSuche.Range("J106:Z120").ClearContents
' wsSuche.Range("J106:Z120").Interior.ColorIndex = xlNone
' wsSuche.Range("J106:Z120").Font.Bold = False
If plz = "" Then Exit Sub ' ohne PLZ keine Suche
' Letzte Zeile in Ansprechpartner
letzte = wsDaten.Cells(wsDaten.Rows.Count, "A").End(xlUp).Row
' Startzeile für ersten Arzt
zeile = 106
anzahl = 0
Application.ScreenUpdating = False
' Definiere Arzt- und BK-Bereiche (anpassen bei weiteren Blöcken)
ArztSpalten = Array("EL", "EV", "FF")
BKSpalten = Array("EM:ET", "EW:FD", "FG:FL")
' Durch alle Datensätze laufen
For i = 7 To letzte
If Trim(wsDaten.Cells(i, "A").Value) = plz Then
' Durch alle Arzt-Bereiche laufen
For b = LBound(ArztSpalten) To UBound(ArztSpalten)
treffer = False
' Spaltennummern ermitteln
arztCol = wsDaten.Columns(ArztSpalten(b)).Column
parts = Split(BKSpalten(b), ":")
startCol = wsDaten.Columns(parts(0)).Column
endCol = wsDaten.Columns(parts(1)).Column
' Prüfen, ob Arztname vorhanden
If Trim(wsDaten.Cells(i, arztCol).Value) > "" Then
' Wenn keine BK-Ziffer angegeben, reicht Arztname
If bk = "" Then
treffer = True
Else
' Prüfen, ob BK in Block vorkommt
For j = startCol To endCol
If Trim(wsDaten.Cells(i, j).Value) = bk Then
treffer = True
Exit For
End If
Next j
End If
' Wenn Treffer -> Ausgabe im gewünschten Layout
If treffer Then
' Arztname in Zeile 'zeile'
wsSuche.Cells(zeile, "J").Value = wsDaten.Cells(i, arztCol).Value
' wsSuche.Cells(zeile, "J").Font.Bold = True
' wsSuche.Cells(zeile, "J").Interior.Color = RGB(230, 230, 230)
' J+1 bleibt leer (bereits gelöscht)
' BK-Ziffern in Zeile 'zeile + 2' (ebenfalls in Spalte J)
bkListe = ""
For j = startCol To endCol
If Trim(wsDaten.Cells(i, j).Value) > "" Then
If bkListe > "" Then bkListe = bkListe & "; "
bkListe = bkListe & wsDaten.Cells(i, j).Value
End If
Next j
wsSuche.Cells(zeile + 2, "J").Value = bkListe
' wsSuche.Cells(zeile + 2, "J").Interior.Color = RGB(245, 245, 245)
' Optional: Formatierung der BK-Zeile normal (nicht fett)
wsSuche.Cells(zeile + 2, "J").Font.Bold = False
' Nächster Arzt beginnt 4 Zeilen weiter
zeile = zeile + 4
anzahl = anzahl + 1
End If
End If
Next b
End If
Next i
Application.ScreenUpdating = True
If anzahl = 0 Then
MsgBox "Kein passender Arzt bzw. keine passende Ärztin gefunden.", vbInformation
Else
MsgBox anzahl & " Arzt/Ärzte/Ärztinnen gefunden.", vbInformation
End If
End Sub
Alles in Allem eine neue Erfahrung für mich.
Grüße - Erwin