Suchfunktion via VBA
17.10.2013 11:45:15
Iten
Ich habe dassele Problem, wie dieser Herr auf dem folgenden Link.
https://www.herber.de/forum/archiv/624to628/627758_Arbeitsmappe_durchsuchen_Ergebnise_anzeigen.html
Ich habe dort folgendes herauskopiert:
Option Base 1
Option Compare Text
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
------------------------------------------------------------------
Jedoch möchte ich paar Anpassungen:
Ich habe ein Tabellenblatt (namens Import) mit diversen Ziffer auf Spalte A:
1000
1100
1250
Ich möchte diese Reihe von Ziffern markieren und gleichzeitig auf verschiedenen Tabellenblätter (über 40) suchen. Jedoch bei allen Tabellenblätter nur auf der Spalte A. Das Ergebnis sollte wieder auf das Tabellenblatt Import angezeigt werden. Wie bei dem oben erwähnten Link sollte nur der Name vom Tabellenblatt angezeigt werden. Es sollte immer nur ein Treffer anzeigen, meines wissen nach. Darum sollte es gleich schön untereinander Stehen:
Es sollte kein zusätzliches Tabellenblatt erstellt werden.
Ich Danke allen die mir eine Antwort schreiben und verbleibe mit freundlichen Grüssen
Tim