Dan nyt worddokument med liste over ord i andet worddokument

Som en begyndelse har jeg forsøgt at lave nedenstående makro. Problemet her er at der ikke indsættes CRLF i WordListDoc dokumentet. Desuden flyttes flyttes cursoren i WordListDoc dokumentet til toppen hver gang der startes på et nyt afsnit i TestMacro dokumentet. Teksten for afsnit 2,3.. indsætes derfor over den allerede indsatte tekst.

Hvordan kan jeg få fat i sidenummeret og linienummeret.

Sub a4()
'
' a4 Macro
    Dim myDoc As Document
    Set myDoc = ActiveDocument
    Dim wordListDoc As Document
    Set wordListDoc = Documents.Add

    myDoc.Activate
    Selection.HomeKey Unit:=wdStory
    For i = 1 To myDoc.Paragraphs.Count
      Dim pRange As Range
      Set pRange = myDoc.Range(myDoc.Paragraphs(i).Range.Start, _
            myDoc.Paragraphs(i).Range.End)
     
      For j = 1 To pRange.Words.Count
        wordListDoc.Words(j).Text = pRange.Words(j).Text
        Dim wRange As Range
        Set wRange = wordListDoc.Range(wordListDoc.Words(j).Start, _
                                      wordListDoc.Words(j).End)
        wRange.InsertAfter (vbCrLf)
     
      Next j
    Next i
End Sub

Jeg har nu selv næsten fået opgaven, men jeg mangler at få fat i sidenummeret på siden hvor ordet er kopieret fra. Kan man det uden først at indsætte sidenumre i det oprindelig dokument.

Sub top()
'
' top Macro
' Macro recorded 10/6/2002 by Sten Madsen
'
    'Selection.HomeKey Unit:=wdStory
    'MsgBox "This is top of document"
    'Application.PrintPreview = True
    Set myDoc = Documents(ActiveDocument)
    'MsgBox ActiveDocument.Words.Count & " words(s) in document " & ActiveDocument.Name
    MsgBox myDoc
    'MsgBox myDoc.Words.Count & " words(s) in document " & myDoc.Name
   
End Sub
Sub wordlist()
'
' wordlist Macro
' Macro recorded 10/12/2002 by Sten Madsen
'
    Documents.Add DocumentType:=wdNewBlankDocument
    Windows("testmacro.doc").Activate
    Selection.MoveLeft Unit:=wdCharacter, Count:=52
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=4, Extend:=wdExtend
    Selection.Copy
    Windows("Document3").Activate
    Windows("testmacro.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=9, Extend:=wdExtend
    Selection.Copy
    Windows("Document3").Activate
    Selection.TypeParagraph
    Windows("testmacro.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Copy
    Windows("Document3").Activate
    Selection.TypeParagraph
    Windows("testmacro.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Copy
    Windows("Document3").Activate
    Selection.TypeParagraph
    Windows("testmacro.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Copy
    Windows("Document3").Activate
    Selection.TypeParagraph
    Selection.PasteAndFormat (wdPasteDefault)
End Sub
Sub a1()
'
' a1 Macro
' Macro recorded 10/12/2002 by Sten Madsen
'
    Dim myDoc As Document
    'set myDoc =
    Documents.Add DocumentType:=wdNewBlankDocument
    myDocName = ActiveDocument.Name
   
    Windows("testmacro.doc").Activate
    Selection.HomeKey Unit:=wdStory
    'Selection.HomeKey Unit:=wdLine
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Copy

    Windows(myDocName).Activate
    Selection.PasteAndFormat (wdPasteDefault)
   
   
   
    'Selection.MoveRight Unit:=wdWord, Count:=1
    'Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    'Selection.Copy
    ' Windows("Document5").Activate

    'Selection.TypeParagraph
    'Windows("testmacro.doc").Activate
    'Selection.PasteAndFormat (wdPasteDefault)
    'Selection.MoveRight Unit:=wdWord, Count:=1
    'Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    'Selection.Copy
    ' Windows("Document5").Activate
    'Windows(myDoc).Activate
    'Selection.TypeParagraph
    'Selection.PasteAndFormat (wdPasteDefault)
End Sub
Sub a2()
'
' a2 Macro
' Macro recorded 10/12/2002 by Sten Madsen
'
    Selection.HomeKey Unit:=wdStory
End Sub
Sub a3()
'
' a3 Macro
' Macro created 10/12/2002 by Sten Madsen
'
    Dim myDoc As Document
    Set myDoc = ActiveDocument
    Dim wordListDoc As Document
    Set wordListDoc = Documents.Add
    Dim wRange As Range
    myDoc.Activate
    Selection.HomeKey Unit:=wdStory
    For i = 1 To myDoc.Words.Count
      wordListDoc.Words(i).Text = myDoc.Words(i).Text
    ' Set wRange = wordListDoc.Range(Start:=wordListDoc.Words(i).Start, End:=wordListDoc.Words(i).End)
    ' wRange.InsertParagraphAfter
    ' wRange.
    Next i

End Sub
Sub a4()
'
' a4 Macro
    Dim myDoc As Document
    Set myDoc = ActiveDocument
    Dim wordListDoc As Document
    Set wordListDoc = Documents.Add
   
    myDoc.Activate
    Selection.HomeKey Unit:=wdStory
    For i = 1 To myDoc.Paragraphs.Count
      Dim pRange As Range
      Set pRange = myDoc.Range(myDoc.Paragraphs(i).Range.Start, _
            myDoc.Paragraphs(i).Range.End)
     
      For j = 1 To pRange.Words.Count
       
        Dim wRange As Range
        Set wRange = wordListDoc.Range(wordListDoc.Range.Start, _
                                      wordListDoc.Range.End)
       
        wRange.InsertAfter "Afsnit " & i & " ord " & j & vbTab & pRange.Words(j).Text
        wRange.InsertAfter vbNewLine

      Next j
    Next i
End Sub

Hov der kom lidt for mange linier kode med. Her er det rigtige udsnit.

Sub a4()
'
' a4 Macro
    Dim myDoc As Document
    Set myDoc = ActiveDocument
    Dim wordListDoc As Document
    Set wordListDoc = Documents.Add
   
    myDoc.Activate
    Selection.HomeKey Unit:=wdStory
    For i = 1 To myDoc.Paragraphs.Count
      Dim pRange As Range
      Set pRange = myDoc.Range(myDoc.Paragraphs(i).Range.Start, _
            myDoc.Paragraphs(i).Range.End)
     
      For j = 1 To pRange.Words.Count
       
        Dim wRange As Range
        Set wRange = wordListDoc.Range(wordListDoc.Range.Start, _
                                      wordListDoc.Range.End)
       
        wRange.InsertAfter "Afsnit " & i & " ord " & j & vbTab & pRange.Words(j).Text
        wRange.InsertAfter vbNewLine

      Next j
    Next i
End Sub