rij invoegen

[Josjosjos]

Ik gebruik de code beneden om waarden te zoeken in een Worddocument, ik zou graag willen weten hoe ik het resultaat

A A1
B B1
C D1
D E1
E E2
F E3
F1


In dit kan veranderen, als ik probeer om de code te veranderen, worden de rijen op de verkeerde plaats ingevoegd.


A A1

B B1

C

D D1

E E1
E2
E3

F F1

        Sub WordZoeken()
        Dim Wapp As Object, STRtoFind As String, Sourcefile As String
        Dim Cnt2 As Integer, Cnt As Integer, Opara As Object
        Dim Lastrow As Integer
        Sourcefile = "C:\testdocument.docx"
        On Error GoTo Erfix
        Set Wapp = CreateObject("Word.Application")
        Wapp.Documents.Open Filename:=Sourcefile, ReadOnly:=True
        With Sheets("Blad1")
            Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
        End With
        For Cnt = 1 To Lastrow
        STRtoFind = CStr(Sheets("Blad1").Range("A" & Cnt).Value)

        For Each Opara In Wapp.ActiveDocument.Paragraphs
        With Opara.Range.Find
        .Text = STRtoFind
        .Forward = True
        .MatchWholeWord = True
        .Execute
        If .found = True Then
        Cnt2 = Cnt2 + 1
        Sheets("Blad1").Range("B" & Cnt2).Value = Opara.Range
        End If
        End With
        Next Opara

        Next Cnt
        Wapp.ActiveDocument.Close savechanges:=False
        Wapp.Quit
        Set Wapp = Nothing
        Exit Sub

Erfix:
        On Error GoTo 0
        MsgBox "Error"
        Wapp.Quit
        Set Wapp = Nothing
        End Sub

 

[snb]

Ik kreeg je Excel voorbeeldbestand en je Wordvoorbeeldbestand niet geopend.

Gebruik svp code tags.