Sub Suche_starten()
Dim y As Integer
Set oDoc = ActiveDocument
Dim Pfad As String
Pfad = "C:\Temp\Begriff.docx"
Dim wksSheet As Worksheet
Set ADoc = Documents(1)
Options.UpdateLinksAtOpen = False
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
If Offen(Pfad) Then
MsgBox "Bitte Tabelle speichern und Schließen"
GoTo end1
Else
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
Set rDoc = AppWD.Documents.Open(Pfad)
a = rDoc.Tables(1).Rows.Count
For i = 2 To a
b = Left(rDoc.Tables(1).Cell(i, 1).Range.Text, _
Len(rDoc.Tables(1).Cell(i, 1).Range.Text) - 2)
C = Left(rDoc.Tables(1).Cell(i, 2).Range.Text, _
Len(rDoc.Tables(1).Cell(i, 2).Range.Text) - 2)
ADoc.Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = (b)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While Selection.Find.Execute
Selection.Comments.Add Range:=Selection.Range, Text:=(C)
y = y + 1
Loop
Next
End If
end1:
Ich hoffe ihr könnt mir helfen :-)
Liebe Grüße
Steffen