Excel: Dialog Suchen & Kopieren in Tabellenblatt in feste Zeile

Hallo Thorsten,
<br />warum verwendest du nicht die Funktion FILTER.
<br />Schreibe in Tabelle2 in A2 die gewünschte ID und du bekommst die anderen Werte gefiltert. Schau mal hier rein:
<br />https://1drv.ms/x/s!AqMiGBK2qniTgfERfdulsUE6cfbwLA?e=XeExgz
<br />Claus
<br />

Bevor Sie den folgenden Code in Ihre Datei kopieren, lesen Sie bitte diesen Artikel:
VBA issues with new forum editor - Microsoft Community
<br />Andreas.
<br />

Option Explicit

Sub Test()
Dim Source As Range, Dest As Range

With Worksheets("Ziel")
'Alle Daten in Ziel löschen, außer Überschriften
.Range("A1").CurrentRegion.Offset(1).ClearContents
'Ziel festlegen
Set Dest = .Range("A2")
End With

'Suche alle IDs
With Worksheets("Quelle")
Set Source = FindAll(.Cells, "ID-202")
'Gefunden?
If Source Is Nothing Then Exit Sub
'Auf Spalten reduzieren
Set Source = Intersect(Source.EntireRow, .Range("A:A,S:S,AA:AA"))
'Kopieren
Source.Copy
Dest.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End Sub

Private Function FindAll(ByVal Where As Range, ByVal What, _
Optional ByVal After As Variant, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
Optional ByVal MatchCase As Boolean = False, _
Optional ByVal SearchFormat As Boolean = False) As Range
'Find all occurrences of What in Where (Windows version)
Dim FirstAddress As String
Dim C As Range
'From FastUnion:
Dim Stack As New Collection
Dim Temp() As Range, Item
Dim i As Long, j As Long

If Where Is Nothing Then Exit Function
If SearchDirection = xlNext And IsMissing(After) Then
'Set After to the last cell in Where to return the first cell in Where in front if _
it match What
Set C = Where.Areas(Where.Areas.Count)
'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
'Set After = C.Cells(C.Cells.Count)
Set After = C.Cells(C.Rows.Count * CDec(C.Columns.Count))
End If

Set C = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
If C Is Nothing Then Exit Function

FirstAddress = C.Address
Do
Stack.Add C
If SearchFormat Then
'If you call this function from an UDF and _
you find only the first cell use this instead
Set C = Where.Find(What, C, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
Else
If SearchDirection = xlNext Then
Set C = Where.FindNext(C)
Else
Set C = Where.FindPrevious(C)
End If
End If
'Can happen if we have merged cells
If C Is Nothing Then Exit Do
Loop Until FirstAddress = C.Address

'FastUnion algorithm © , 2011:
'Get all cells as fragments
ReDim Temp(0 To Stack.Count - 1)
i = 0
For Each Item In Stack
Set Temp(i) = Item
i = i + 1
Next
'Combine each fragment with the next one
j = 1
Do
For i = 0 To UBound(Temp) - j Step j * 2
Set Temp(i) = Union(Temp(i), Temp(i + j))
Next
j = j * 2
Loop Until j > UBound(Temp)
'At this point we have all cells in the first fragment
Set FindAll = Temp(0)
End Function

Hallo Thorsten,
<br />da du nur nach einem Eintrag suchst, kannst du das auch über INDEX/VERGLEICH erreichen.
<br />Schau nochmals in OneDrive vorbei.
<br />Claus
<br />

Hallo Thorsten,
<br />die Funktion steht zur Zeit nur in Microsoft 365 zur Verfügung.
<br />Claus
<br />

Hallo Claus,
<br />die Idee finde ich wirklich klasse.
<br />Bei Excel 2016 zeigt er mir allerdings "Die Funktion ist ungültig" .
<br />Wollte es in meiner Test-Datei gerade ausprobieren.
<br />Liegt das an der Excel-Version.
<br />Gruß
<br />Thorsten
<br />