Codeerweiterung fürSuchen

Sub Suchen() Dim Eingabe As String Dim Feld As Range Dim Gefunden As Boolean Dim Antwort As Long Eingabe = InputBox("Bitte Aktenzeichen als Suckriterium eingeben", "Suchmaschine") If Eingabe "" Then For Each Feld In ActiveSheet.UsedRange If InStr(UCase(CStr(Feld.Value)), UCase(Eingabe)) > 0 Then Gefunden = True Feld.Activate Antwort = MsgBox("Weitersuchen?", vbQuestion + vbYesNo, "Frage") If Antwort = vbNo Then Exit For End If End If Next Feld If Gefunden = False Then MsgBox "'" & Eingabe & "' nicht gefunden! Bitte Button >> Neuer Eintrag

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Suchen() Dim rng As Range Dim strFirst As String, strFind As String With ActiveSheet strFind = InputBox("Bitte Aktenzeichen als Suckriterium eingeben", "Suchmaschine") If strFind <> "" Then Set rng = .Cells.Find(What:=strFind, LookIn:=xlValues, LookAt:=xlPart, _ MatchCase:=False, After:=Cells(.Rows.Count, .Columns.Count)) If Not rng Is Nothing Then strFirst = rng.Address Do Application.Goto rng, True If MsgBox("Weitersuchen?", vbQuestion + vbYesNo, "Frage") = vbNo Then Exit Do Set rng = .Cells.FindNext(rng) Loop While Not rng Is Nothing And strFirst <> rng.Address If rng Is Nothing Then MsgBox "Keine weiteren Treffer!", vbInformation, "Hinweis" Else MsgBox "'" & strFind & "' nicht gefunden! Bitte Button >> Neuer Eintrag << verwenden", _ vbInformation, "Schade" End If End If End With Set rng = Nothing End Sub

Hallo Sepp,
erstmal Danke, dass du mir mit der Codeerweiterung geholfen hast.
Habe jetzt festgestellt, dass die Abfrage bei ca. 12.000 Zeilen wesentlich länger läuft.
Kann man die Suche vielleicht auf die Spalten E und F (nur da sind Aktenzeichen enthalten) begrenzen, damit die Suche schneller läuft?
Und das mit >> Neuer Eintrag Findet die Suche nichts, sollte bei der Meldung "...nix gefunden.." die Möglichkeit gegeben sein, einen neuen Button anzuklicken, wo ein Code hinterlegt werden kann, der schon existiert:

Sub Neuer_Eintrag()
IIf(IsEmpty([a65536]), Cells(Rows.Count, 1).End(xlUp), [a65536]).Select
ActiveCell.Offset(1, 0).Select
End Sub

Aber das wird wahrscheinlich nicht mit der MSG Box funktionieren?`
Erwin

Sub Suchen() Dim rng As Range Dim strFirst As String, strFind As String With ActiveSheet strFind = InputBox("Bitte Aktenzeichen als Suckriterium eingeben", "Suchmaschine") If strFind <> "" Then Set rng = .Range("E:F").Find(What:=strFind, LookIn:=xlValues, LookAt:=xlPart, _ MatchCase:=False, After:=Cells(.Rows.Count, 6)) If Not rng Is Nothing Then strFirst = rng.Address Do Application.Goto rng If MsgBox("Weitersuchen?", vbQuestion + vbYesNo, "Frage") = vbNo Then Exit Do Set rng = .Range("E:F").FindNext(rng) Loop While Not rng Is Nothing And strFirst <> rng.Address If rng Is Nothing Then MsgBox "Keine weiteren Treffer!", vbInformation, "Hinweis" Else MsgBox "Gesamter Bereich durchsucht!", vbInformation, "Hinweis" End If Else If MsgBox("'" & strFind & "' nicht gefunden!" & vbLf & vbLf & _ "Wollen Sie einen neuen Eintrag erstellen?", vbQuestion + vbYesNo, _ "Frage") = vbYes Then Application.Goto .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) End If End If End If End With Set rng = Nothing End Sub

Hallo Erwin,
dann halt so.

Sub Suchen_3()
  Dim rng As Range
  Dim strFirst As String, strFind As String
  
  Range("A1").Select
  
  With ActiveSheet
    strFind = InputBox("Bitte Aktenzeichen als Suckriterium eingeben", "Suchmaschine")
    
    If strFind <> "" Then
      Set rng = .Range("E:F").Find(What:=strFind, LookIn:=xlValues, LookAt:=xlPart, _
        MatchCase:=False, After:=Cells(.Rows.Count, 6))
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          Application.Goto rng
          If MsgBox("Weitersuchen?", vbQuestion + vbYesNo, "Frage") = vbNo Then Exit Do
          Set rng = .Range("E:F").FindNext(rng)
        Loop While Not rng Is Nothing And strFirst <> rng.Address
        MsgBox "Keine weiteren Treffer!", vbInformation, "Hinweis"
      Else
        If MsgBox("'" & strFind & "' nicht gefunden!" & vbLf & vbLf & _
          "Wollen Sie einen neuen Eintrag erstellen?", vbQuestion + vbYesNo, _
          "Frage") = vbYes Then
          
          Application.Goto .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
      End If
    End If
  End With
  
  Set rng = Nothing
  
  
End Sub

Außerdem solltest du, wenn du eine Datei hochlädtst, entweder das Passwort bekanntgeben, oder die Abfrage deaktivieren!
Dein Passwortschutz ist aber für die Katz, zumindest hatte ich, auch ohne Passwort, kein Problem die Datei zu öffnen.

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Codeerweiterung fürSuchen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread