Button führt suche durch und exportiert gefundene Zeilen

Sub CreateButtonAndDropdown()

Dim ws As Worksheet

Dim startWs As Worksheet

Dim dd As DropDown

Dim btn As Button

Dim cell As Range

Dim uniqueNames As Collection

Dim nameRange1 As Range

Dim nameRange2 As Range



' Arbeitsblatt "Startseite" setzen

Set startWs = ThisWorkbook.Sheets("Startseite")



' Lösche bestehende Buttons oder Dropdown-Menüs

On Error Resume Next

startWs.DropDowns("BeraterAuswahl").Delete

startWs.Buttons("SearchButton").Delete

On Error GoTo 0



' Erstelle eine Liste an unterschiedlichen Namen

Set uniqueNames = New Collection



' Definiere den Bereich der Berater Namen in Worksheet "RM"

Set nameRange1 = ThisWorkbook.Sheets("RM").Range("A3:A11")

Set nameRange2 = ThisWorkbook.Sheets("RM").Range("B3:B8")



' Durchsuche die beiden Listen nach Namen

On Error Resume Next ' Ignoriere Fehler bei doppelten Einträgen

For Each cell In nameRange1

    If cell.Value > "" Then uniqueNames.Add cell.Value, CStr(cell.Value)

Next cell

For Each cell In nameRange2

    If cell.Value > "" Then uniqueNames.Add cell.Value, CStr(cell.Value)

Next cell

On Error GoTo 0 ' Fehlerbehandlung zurücksetzen



' Erstelle das Dropdown-Menü für die Namenauswahl

Set dd = startWs.DropDowns.Add(10, 635, 150, 15)

dd.Name = "BeraterAuswahl"

dd.ListFillRange = "" ' Leere die Liste anfangs



' Fülle die Dropdown-Liste mit Namen

For i = 1 To uniqueNames.Count

    dd.AddItem uniqueNames(i)

    Next i



' Erstelle den Suchen Button um die Suche zu starten

Set btn = startWs.Buttons.Add(200, 635, 100, 30)

btn.Name = "SearchButton"

btn.OnAction = "SearchByName"

btn.Caption = "Suchen"

End Sub

Sub SearchByName()

    Debug.Print "Die SearchByName Sub wurde gestartet." ' Diese Zeile zur Überprüfung ob der Code startet



    Dim ws As Worksheet

    Dim startWs As Worksheet

    Dim newWb As Workbook

    Dim newWs As Worksheet

    Dim lastRow As Long

    Dim searchName As String

    Dim outputRow As Long

    Dim i As Long

    Dim j As Long

    Dim cellValue As String



' Arbeitsblatt "Startseite" setzen

Set startWs = ThisWorkbook.Sheets("Startseite")



' Ausgewählten Berater aus dem Dropdown auslesen

On Error Resume Next

searchName = Trim(startWs.DropDowns("BeraterAuswahl").List(startWs.DropDowns("BeraterAuswahl").ListIndex))

On Error GoTo 0



' Prüfen, ob ein Berater ausgewählt wurde

If searchName = "" Then

    MsgBox "Bitte wählen Sie einen Berater aus dem Dropdown-Menü aus.", vbExclamation

    Exit Sub

End If



Debug.Print "Gesuchter Berater: " & searchName & "." ' Überprüfung, ob der richtige Berater ausgewählt wurde



' Neues Workbook erstellen für die Ergebnisse

Set newWb = Workbooks.Add

Set newWs = newWb.Sheets(1)

newWb.SaveAs "Suchergebnisse_Nichtkunden_" & searchName & ".xlsx"



' Spaltenüberschriften in das neue Arbeitsblatt einfügen

With newWs

    .Range("A1").Value = "Firma"

    .Range("B1").Value = "Ort"

    .Range("C1").Value = "Geschäftszweck"

    .Range("D1").Value = "Umsatz in M€"

    .Range("E1").Value = "Ansprechpartner"

    .Range("F1").Value = "Letzter Kontakt"

    .Range("G1").Value = "Information"

End With



outputRow = 2 'Startreihe für Daten



Debug.Print "Neue Datei wurde erstellt."



' Durchsuche alle Arbeitsblätter nach dem gesuchten Berater

For Each ws In ThisWorkbook.Sheets

    If ws.Name > "Startseite" And ws.Name > "RM" And ws.Name > "Blanko" Then ' Überspringe die anderen Blätter

        lastRow = ws.Cells(ws.Rows.Count, 1).End(x1Up).Row ' Letzte Zeile im aktuellen Blatt

        

        Set searchRange = ws.Range("A9:H" & lastRow) ' Definiert den Suchbereich zwischen A9 und der letzten Zeile

        

        Debug.Print "Suchbereich definiert"

        

        ' Suche nach dem Berater im Suchbereich

        Set foundCell = searchRange.Find(What:=searchName, LookIn:=x1Values, LookAt:=x1Part)

        

        If Not foundCell Is Nothing Then

            firstAdress = foundCell.Adress ' Speicher die erste Adresse

            

            Debug.Print "Erste Adresse gespeichert"

            Do

                ' Überprüfe, ob die gefundene Zelle in die neue Datei kopiert werden soll

                ' Hier wird die gesamte Zeile kopiert, man kann dies anpassen je nach Bedarf

                ws.Rows(foundCell.Row).Copy Destination:=newWs.Rows(outputRow)

                outputRow = outputRow + 1 'Nächste Zeile in der neuen Datei

                Set foundCell = searchRange.FindNext(foundCell) ' Nächste Fundstelle suchen

            Loop While Not foundCell Is Nothing And foundCell.Address > firstAdress

        End If

    End If

Next ws



Debug.Print "Suche abgeschlossen."

MsgBox "Sie Suche nach " & searchName & "wurde abgeschlossen. Die Ergenisse wurden gespeichert.", vbInformation

End Sub