Eindeutige Werte bzw. Textteile suchen

Sub Suchen() ' SUCHEN - Sucht den eingegeben Text in sämtlichen Zellen und blendet diese ein. Application.ScreenUpdating = False Range("4:2000").EntireRow.Hidden = True Dim Zelle As Range Dim Bereich As Range Dim rngGefunden As Range Dim Eingabe As String 'String Set Bereich = Range("B4:D" & Cells(Rows.Count, 1).End(xlUp).Row) Eingabe = UCase(InputBox("Was soll gesucht werden?", "Suchen")) If StrPtr(Eingabe) = 0 Then Exit Sub If Trim$(Eingabe) = "" Then Exit Sub For Each Zelle In Bereich If InStr(UCase(Zelle.Value), Eingabe) > 0 Then If Not rngGefunden Is Nothing Then Set rngGefunden = Union(rngGefunden, Rows(Zelle.Row)) Else Set rngGefunden = Rows(Zelle.Row) End If End If Next Zelle If Not rngGefunden Is Nothing Then rngGefunden.Select Selection.EntireRow.Hidden = False ActiveCell.Select ActiveSheet.OLEObjects("CommandButton1").Enabled = True ActiveSheet.OLEObjects("CommandButton2").Enabled = True ActiveSheet.OLEObjects("CommandButton3").Enabled = True ActiveSheet.OLEObjects("CommandButton4").Enabled = True ActiveSheet.OLEObjects("CommandButton5").Enabled = True MsgBox "Achtung! Die zu bearbeitende Zeile ist vorab zu selektieren!" Else MsgBox ">> " & Eingabe & "

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo ?,
so kannst du auch mit Wildcards (*, ?) suchen.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Suchen() ' SUCHEN - Sucht den eingegeben Text in sämtlichen Zellen und blendet diese ein.
Dim rngSearch As Range, rngFind As Range, rngHide As Range
Dim strInput As String, strFirst As String
Dim lngRow() As Long

Static CalculationMode As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

Range("4:2000").EntireRow.Hidden = False

Redim lngRow(0)

Set rngSearch = Range("B4:D" & Cells(Rows.Count, 1).End(xlUp).Row)

strInput = InputBox("Was soll gesucht werden?", "Suchen")

If Len(Trim$(strInput)) Then
  
  Set rngFind = rngSearch.Find(What:=strInput, LookIn:=xlValues, _
    LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
  
  If Not rngFind Is Nothing Then
    strFirst = rngFind.Address
    Do
      If IsError(Application.Match(rngFind, lngRow, 0)) Then
        Redim Preserve lngRow(UBound(lngRow) + 1)
        lngRow(UBound(lngRow)) = rngFind.Row
        If rngHide Is Nothing Then
          Set rngHide = rngFind
        Else
          Set rngHide = Union(rngHide, rngFind)
        End If
      End If
      Set rngFind = rngSearch.FindNext(rngFind)
    Loop While Not rngFind Is Nothing And strFirst <> rngFind.Address
  End If
  
  If Not rngFind Is Nothing Then
    Range("4:2000").EntireRow.Hidden = True
    rngHide.EntireRow.Hidden = False
    ActiveCell.Select
    ActiveSheet.OLEObjects("CommandButton1").Enabled = True
    ActiveSheet.OLEObjects("CommandButton2").Enabled = True
    ActiveSheet.OLEObjects("CommandButton3").Enabled = True
    ActiveSheet.OLEObjects("CommandButton4").Enabled = True
    ActiveSheet.OLEObjects("CommandButton5").Enabled = True
    MsgBox "Achtung! Die zu bearbeitende Zeile ist vorab zu selektieren!"
  Else
    MsgBox ">> " & strInput & "<<, wurde nicht gefunden"
  End If
End If

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'nn'" & vbLf & String(25, "") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, 81968, "VBA - Fehler in Prozedur - Suchen", .HelpFile, .HelpContext
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

Set rngHide = Nothing
Set rngSearch = Nothing
Set rngFind = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Eindeutige Werte bzw. Textteile suchen

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Eindeutige Werte bzw. Textteile suchen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread