Suchfunktion via VBA
24.10.2013 11:03:47
Tim
Ich habe folgenden Code:
Sub Suchen_und_anzeigen()
Dim Meldung As Byte, Pos As Byte
Dim Schleife As Byte, y As Byte
Dim Begriff, Suchen() As Variant
Dim Bereich As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), Text$
' Suchbegriff eingeben
Begriff = InputBox _
("Bitte den zu suchenden Wert eingeben. Sollen 2 Werte" & vbCrLf & _
"gleichzeitig gesucht werden, dann mit Zeichen + " & vbCrLf & _
"voneinander trennen (z.B.: Summe+die)." & vbCrLf & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For y = 1 To Schleife
For n = 1 To Sheets.Count
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = Worksheets(n).UsedRange
With Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address ErsteAdresse
End If
End With
Next n
Next y
Application.ScreenUpdating = True
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
vbOKOnly, "G E F U N D E N E W E R T E")
Exit Sub
Case Else
Meldung = MsgBox("Es wurden " & (x - 1) & " Übereinstimmungen gefunden.", _
vbOKOnly, "G E F U N D E N E W E R T E")
'Tabelle einfügen
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
On Error Resume Next
With ActiveSheet
.Name = "Suchergebnis"
.[A1] = "Tabelle"
.[B1] = "Zelle"
For n = 1 To x - 1
.Cells(n + 1, 1) = xTabelle(n)
.Cells(n + 1, 2) = Adresse(n)
Next n
End With
End Select
End Sub
Dieser Code macht folgendes: Wenn ich ein Button drücke, öffnet es ein Fenster; Dort kann ich meine Suchwörter bzw. mehrere Zahlen gleichzeitig eingeben; dann sucht es diese und listet die Treffer in einem seperatem Tabellenblatt, welches neu erstellt wird durch den programmierten Code, auf.
Jedoch möchte ich diese gerne folgendermassen anpassen:
Gemäss meiner Datei: https://www.herber.de/bbs/user/87746.xls
Wenn ich auf das Feld Suchen drücke, möchte ich im Tabellenblatt "Import" Kto.Nr (Spalte A) mehrere Zahlen markieren und nicht eingeben, diese Zahlen sollen gesucht werden in allen Tabellenblätter ausser auf deren Tabllenblatt, auf dieser ich mich aktuell befinde (Tabellenblatt Import). Jedoch soll diese Suche in allen Arbeitspapieren nur auf der Spalte A geschehen. Dies bedeutet, es soll nur auf der Spalte A bei allen Blättern gesucht werden. Soweit ich weiss gibt es für jede Zahl nur einen Treffer. Die Treffer sollen bei F11 & H11 (Tabellenblatt Import) schön untereinander angezeigt werden mit den Namen von Tabellenblatt und mit der Zeile.
Es darf kein zusätzliches Blatt erstellt werden.
Beispiel
Wenn ich die Zahl 1000 (Spalte A, Zeile 5)suche, soll der Treffer auch auf Zeile 5 gezeigt werden, jedoch ein paar Spalten weiter (siehe Download link).
Ich Danke allen die mir eine Antwort schreiben und verbleibe mit freundlichen Grüssen
Tim