'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@gmx.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+  suche den Inhalt der aktiven Zelle in allen Arbeitsblättern AUSSER Tabelle(3)
'+  diese dient hier als Ergebnisausgabe! Sammle alle rechten Nachbarzellen in
'+  einer Collection und gib Blattname, Adresse und Inhalt in einer Liste aus
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub suchen_und_einfuegen()
suchwert = ActiveCell.Value
Dim c As New Collection
Dim r As Range
Dim r1 As Range
Dim ur1 As Range
Dim sh As Worksheet
Dim ausgabe_in_sh As String

ausgabe_in_sh = "Tabelle3"

For Each sh In Worksheets
    If sh.Name <> ausgabe_in_sh Then
        Set ur1 = sh.UsedRange 'aktualisierung von UsedRange!
        Set r = ur1.Find(suchwert, lookat:=xlWhole, MatchCase:=True)
        Set r1 = r
        Do While Not r Is Nothing
            c.Add sh.Name
            c.Add r.Offset(0, 1)
            Set r = ur1.FindNext(r)
            If r.Address = r1.Address Then Set r = Nothing
            Loop
        End If
    Next

Set sh = Sheets(ausgabe_in_sh)
Application.ScreenUpdating = False
sh.Cells.Clear
sh.Cells(1, 1) = suchwert
If IsError(c.Count) Then Exit Sub
For i = 1 To c.Count Step 2
   sh.Cells(1).Offset(i \ 2 + 1, 0) = c.Item(i)
   sh.Cells(1).Offset(i \ 2 + 1, 1) = c.Item(i + 1).Address
   sh.Cells(1).Offset(i \ 2 + 1, 2) = c.Item(i + 1).Value
   Next
Application.ScreenUpdating = True
sh.Select

End Sub