Schleife um mehrfach ein gesuchte KW in einem neuen Dokument auszugeben + Title

[marcel.o]

Hallo liebe Community,

ich habe folgendes Problem und suche nach eurem Rat. Ich habe ein VBA das soweit funktioniert, es fehlen nur noch kleine Ausbesserungen. Das VBA- soll durch eine Eingabe der KW in einem Dokument(nur Tabellen) nach allen KW suchen und diese Plus Überschrift und Unterüberschrift mit gleicher Formatierung in ein neues Dokument kopieren, soweit so gut.

OProbleme

-das VBA- sucht und markiert nur die erste gefundene KW(bzw. Begriff) in der ersten Tabelle. -> nötig wäre es aber alle zu finden und in ein extra Doc einzufügen

-es gibt Unterüberschriften, welche noch nicht formatiert sind( würde sie mit einer bestimmten Farbe hinterlegen, damit man nach Ihnen suchen kann, aber wie?) bisher werden einfach die ersten beiden Zeilen der Tabelle markiert und kopiert, nun gibt es aber mehrere Unterüberschriften. Die möchte ich mit der Hauptüberschrift der Tabelle kopieren und in das neue Dokument vor der gesuchten KW und deren Zeilen kopieren.

Code:

'Funktion für KW
Function DINKw(Datum As Date) As Integer
Dim lngT As Long
lngT = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKw = 1 + ((Datum - lngT - 3 + (Weekday(lngT) + 1) Mod 7)) / 7 + 1
'ohne 1 + wird die aktuelle KW ausgegeben
End Function

Sub trefferSuchbegriff()
Dim suchbereich As Range, BereichUe As Range, trefferzeile As Range
Dim w As String
Dim trefferSuchbegriff As Table
Dim UE_start As Long, UE_ende As Long
Dim nDoc As Document, qdoc As Document
Dim i As Long

'Quelldokument und Zieldokument als Objekte definieren
Set qdoc = ActiveDocument
Set nDoc = Documents.Add
nDoc.PageSetup.Orientation = wdOrientLandscape

'Suchbegriff fragen
w = InputBox("Was soll gesucht werden?", , "KW" & DINKw(Date))

'abbrechen oder ungültige Eingabe der Inputbox zum Beenden des Makros
If w = "" Or w = "Falsch" Then Exit Sub


For i = 1 To qdoc.Tables.Count


'Im Quelldokument jede Tabelle einzeln abklappern
Set suchbereich = qdoc.Tables(i).Range

'dort Suchbegriff finden und markieren
With suchbereich.Find
.Text = w
.Execute
If .Found = True Then
suchbereich.Select
Else
Set suchbereich = Nothing
'Selection = "" war der Fehler
qdoc.Range(0, 0).Select
End If
End With

'nur bei Treffern in Tabellen reagieren
If Selection.Information(wdWithInTable) Then
'ganze Zeile, in der der Suchbegriff steht, als Bereich definieren
Set trefferSuchbegriff = Selection.Tables(1)
Selection.Expand unit:=wdRow
Set trefferzeile = Selection.Range

'zusätzlich die ersten beiden Tabellenzellen als Bereich definieren
UE_start = trefferSuchbegriff.Cell(1, 1).Range.Start
UE_ende = trefferSuchbegriff.Cell(2, trefferSuchbegriff.Columns.Count).Range.End
Set BereichUe = qdoc.Range(UE_start, UE_ende)

'beide Bereiche ins neue Dokument übertragen und aneinander anhängen
BereichUe.Copy

With nDoc
.Paragraphs.Last.Range.Paste
trefferzeile.Copy
.Paragraphs.Last.Range.Paste
.Paragraphs.Last.Range.InsertAfter vbLf
End With
End If
Next i

End Sub

Im Vorhinein vielen Dank für eure Hilfe!! bin über jeden konstruktiven Beitrag froh.

Grüße

Marcel