title image


Smiley VBA mehrfache Auswahl des Suchbegriffs

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



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: