Hier ein Beispielcode. Passe ihn entsprechend an. Bei weiteren Fragen mailen. mfg, GraFri
--------------------------------------------------------'Erstelle in der Tabelle ein Commandbutton (cmdStart)
'eine Textfeld (TxAnzeige) und ein Listenfeld (LbAnzeige)
Option Base 1
Option Compare Text
Dim xTabelle() As String
Dim xAdresse() As String
Dim xInhalt() As Variant
Sub Suchen_und_anzeigen()
Dim n%, x%, xZelle%, yZelle%
Dim Meldung As Byte
Dim Bereich As String
Dim Suchen As Variant
'Bereich festlegen
Bereich = Application.InputBox("Bitte den zu durchsuchenden Bereich" & vbCrLf & _
"eingeben (z.B.: A1:T200)", "Bereich festlegen", "A1:T200", 8)
' Suchbegriff eingeben
Suchen = InputBox("Bitte den zu suchenden Wert hier eingeben." & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Suchen = "" Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' letzte Zelle im Bereich ermitteln
With Worksheets(1).Range(Bereich)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For n = 1 To Sheets.Count
With Sheets(n).Range(Bereich)
Set c = .Find(Suchen, After:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve xAdresse(x)
ReDim Preserve xTabelle(x)
ReDim Preserve xInhalt(x)
'In welchem Tabellenblatt gefunden
xTabelle(x) = Sheets(n).Name
'Adresse der Zelle
xAdresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
'Inhalt dieser Zelle
xInhalt(x) = Sheets(xTabelle(x)).Range(xAdresse(x)).Value
Set c = .FindNext©
x = x + 1
Loop While Not c Is Nothing And c.Address <> ErsteAdresse
End If
End With
Next n
' Anzeige der Suchergebnisse
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' 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")
Case 2
With LbAnzeige
.Clear
.AddItem xTabelle(n) & " in der Zelle: " & xAdresse(n)
End With
Case Else
With LbAnzeige
.Clear
For n = 1 To x - 1
.AddItem xTabelle(n) & " in der Zelle: " & xAdresse(n)
Next n
.ListIndex = 0
End With
End Select
End Sub
'Listenfeld in der Tabelle mit dem Namen 'LbAnzeige'
Private Sub LbAnzeige_Click()
On Error Resume Next
TxAnzeige = xInhalt(LbAnzeige.ListIndex + 1)
End Sub
'Button in der Tabelle mit dem Namen 'CmdStart'
Private Sub CmdStarten_Click()
Call Suchen_und_anzeigen
End Sub
--------------------------------------------------------