Hallo VBA-Profis,

ich habe hier eine Suchfunktion, die soweit eigentlich gut funktioniert, vielleicht etwas kompliziert ist, aber naja.
Was noch fehlt, ich aber irgendwie nicht zustande bringe, ist folgendes:
Auf Tabelle12 ist eine Suche hinterlegt, die einen Begriff oder Zahl in allen Tabellenblättern sucht und auf Tabelle12 dann ablegt/kopiert. Nun sollte noch die jeweilige Überschrift aus den einzelnen Tabellenblättern (A11:AJ11) nach einer Leerzeile eingetragen werden, da die Überschriften nicht immer gleich sind. Quasi soll das Blatt durchsucht werden, wenn dort das Gesuchte vorhanden ist, dann Überschrift kopieren und die Werte aus den Zeilen eintragen, eine Zeile frei, danach die nächste Tabelle......
Bis jetzt läuft die Suche durch, die Überschrift aus der ersten Tabelle wird eingetragen und dann darunter alle gefundenen Werte aus allen Tabellenblättern.

So sieht die Sache im Moment aus, leider kann ich euch keine Beispieldatei senden.

Sub FindenUndKopieren()
Dim rngSuch As Range
Dim wks As Worksheet
Dim wksDst As Worksheet
Dim strSuch As String
Dim rngFound As Range
Dim strFirst As String
Dim FoundAdr As String
Dim ZeSrc As Integer
Dim ZeDst As Integer
Dim lRow As Long
Dim lRowDst As Long
'Dim RaZelle As Range

With ThisWorkbook.Worksheets("Suche")
.Range("A8:XFD20000").Clear
Zeile = 9
End With


Set wksDst = Tabelle12
strSuch = Range("A2")
If strSuch = "" Then Exit Sub
For Each wks In Worksheets
If Not wks.Name = "Suche" Then
Set rngSuch = wks.Range("A12:H100,V1:W100,AG1:AJ100").Find(strSuch, lookat:=xlPart, LookIn:=xlValues)
End If
With rngSuch
Set rngFound = wks.Range("A12:H100,V1:W100,AG1:AJ100").Find(what:=strSuch, LookIn:=xlValues)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
FoundAdr = rngFound.Address
ZeSrc = rngFound.Row
ZeDst = wksDst.Cells(Rows.Count, 1).End(xlUp).Row + 1
wks.Range("A11:AJ11").Copy wksDst.Cells(9, 1) 'Überschrift kopieren
ZeDst2 = wksDst.Cells(Rows.Count, 1).End(xlUp).Row + 1
wks.Range("A" & ZeSrc & ":XFD" & ZeSrc).Copy wksDst.Cells(ZeDst2, 1) 'Zeile kopieren
Set rngFound = wks.Range("A12:H100,V1:W100,AG1:AJ100").FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address > strFirst
End If

End With
Next

End Sub


Schon mal vorab vielen Dank
Christian