Excel alle Treffer eines Suchmustern zugänglich machen

Mit Excel gibt es die Suchen-Funktion. Diese liefert Treffer, auch über die gesamte Arbeitsmappe.

exce suche treffer

Es gibt aber noch keine Möglichkeit die Trefferliste zu exportieren oder zu kopieren

Diese kleine VBA-Script scheibt die Treffen in eine eigenes Tabellen-Blatt

Vorarbeit:
- In den VBA-Editor wechsel: ALT-F11
- Menü -> Einfügen Modul
- VBA-Code kopieren und einfügen
- Excel-Mappe als .xlsm speichern
- In den Optionen sollte das Menüband angepasst werden und die Entwicklertools aktiviert sein
- Sollten Markos nicht erlaubt sein diese aktivieren
  -> Truste Center -> Eiinstellungen für das Trust Center
  -> Makroeinstellungen müssen mindestens auf "Alle Makros mit Benachrigitgung deaktivieren" gestellt sein
- Im Menüpunkt gibt es jetzt die Entwickertools

Ausführen:
Makros-Button aklicken

exce suche makro exce suche suchmuster

 

Script:

Option Explicit

Sub FindString()
  '#########################################
  Const cTabellennameTreffer = "Treffer"
  '#########################################
  
  Dim c As Range
  Dim ws As Worksheet, wsTreffer As Worksheet
  Dim wb As Workbook
  Dim suchMuster As String
  Dim i As Integer
    
  suchMuster = InputBox("Bitte Suchmuster eingeben" & vbCrLf & "Voreingestellt ist exakter Treffer" & vbCrLf & "Sonst Platzhalter verwenden" & vbCrLf & " ->  *" & vbCrLf & " ->  ?", "Trefferliste erstellen", ActiveCell.Value)
  If suchMuster = "" Or Replace(Replace(suchMuster, "?", ""), "*", "") = "" Then
    MsgBox "Leeres Suchmuster ''", vbOKOnly, "Abbruch der Suche"
    GoTo Exit_:
  End If
  Application.ScreenUpdating = False
  Set wb = ActiveWorkbook
  On Error Resume Next
  Set wsTreffer = wb.Worksheets(cTabellennameTreffer)
  If wsTreffer Is Nothing Then
    Set wsTreffer = wb.Worksheets.Add
    With wsTreffer
     .Name = "Treffer"
     .Range("A1") = "Zelle"
     .Range("B1") = "Tabelle"
     .Range("C1") = "Zellinhalt"
     .Range("D1") = "Verknüpfung"     
     .Rows("1:1").Font.Bold = True
     .Activate
      With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
      End With
    End With
    ActiveWindow.FreezePanes = True
  End If
  wsTreffer.Range("A2:D100000") = ""
  On Error GoTo Errors_
  i = 2
  For Each ws In wb.Worksheets
    If ws.Name <> "Treffer" Then
      With ws.Range("A1:AZZ100000")
        Set c = .Find(suchMuster, LookIn:=xlValues)
        If Not c Is Nothing Then
          Do
            Set c = .FindNext()
            If Not c Is Nothing Then
              wsTreffer.Cells(i, 1) = c.Address
              wsTreffer.Cells(i, 2) = ws.Name
              wsTreffer.Cells(i, 3) = c.Value
              wsTreffer.Cells(i, 4) = " =" & IIf(InStr(1, ws.Name, " ", vbTextCompare), "'", "") & ws.Name & IIf(InStr(1, ws.Name, " ", vbTextCompare), "'!", "!") & c.Address
              c.Value = Replace(c.Value, c.Value, "|-|")
              i = i + 1
            End If
          Loop While Not c Is Nothing
        End If
      End With
    End If
  Next
  i = 2
  With wsTreffer
    While .Cells(i, 1) <> ""
      Set ws = wb.Worksheets(.Cells(i, 2).Value)
      Set c = ws.Range(.Cells(i, 1).Value)
      c.Value = .Cells(i, 3)
      i = i + 1
    Wend
    .Activate
  End With
  Set ws = Nothing
  Set wsTreffer = Nothing
  Set wb = Nothing
  
Exit_:
  Application.ScreenUpdating = True
  Exit Sub
Errors_:
  Err.Clear
  GoTo Exit_
End Sub

 

Hauptmenü

Anmeldeformular