Copying Answers from Word to Excel how can i do this? is there a simple way

[oldmanwilly]

Hi

need to copy the answers of 50 questions in word into excel. The word document also contains tables. here is a link to the first part of the questionnaire questionnaire-part-1 and here is a link to the how the tables look in the file: questionnaire-part-2. Ideally i want column A to have the question(which i can just manually enter, and column B to have the answer. Where there are tables i want them to be placed in a separate sheet with each table table header(i maunually just enter these) and row corresponds to the answer in the word document.

I had an idea of creating bookmarks for each question and then pasting in what was after the bookmark. But maybe thats not possible due to bookmarking would need to be done on every new document? i found the below code but while there is no error the code doesnt paste anything.

sub TryThis()
Dim oWord As Word.Application
Dim oDoc As Word.document
Dim vBkMarks As Variant
Dim vRecord
Dim rRecord As Range
Dim nFields As Long
Dim i As Long

vBkMarks = Array("Bookmark1", "Bookmark2", "Bookmark3") 'etc...
ReDim vRecord(LBound(vBkMarks) To UBound(vBkMarks))
nFields = UBound(vBkMarks) - LBound(vBkMarks) + 1
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
On Error GoTo 0
If oWord Is Nothing Then _
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.ActiveDocument
For i = LBound(vBkMarks) To UBound(vBkMarks)
vRecord(i) = oDoc.Bookmarks(vBkMarks(i)).Range.Text
Next i
With Sheets("DataTable")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _
1, nFields).Value = vRecord
End With
End Sub

could you try and help me?


Thanks

 

[oldmanwilly]

Sub merge()

    Application.DisplayAlerts = False 'Disable all the Alerts from excel
    Application.ScreenUpdating = False 'After opening Word Doc, Document will not be visible
    'Create a New Object for Microsoft Word Application
    Dim objWord As New Word.Application
    'Create a New Word Document Object
    Dim objDoc As New Word.Document
   
    Dim wdApp As Word.Application, wdDoc As Word.Document
Dim wdPage As Word.Page, wdRectangle As Word.Rectangle
Dim wdLine As Word.Line
Dim LineCounter As Long, TextOfLine As String
    'Open a Word Document and Set it to the newly created object above
    Set objDoc = objWord.Documents.Open("mypath.docx")
    'To Store all the content of that word Document in a variable
    LineCounter = 0: TextOfLine = ""
For Each wdPage In objDoc.ActiveWindow.Panes(1).Pages
    For Each wdRectangle In wdPage.Rectangles
        For Each wdLine In wdRectangle.Lines
            With wdLine.Range
                If .InRange(objWord.Selection.Range) Then
                    TextOfLine = wdLine.Range.Text
                    ActiveCell.Offset(LineCounter, 0) = TextOfLine
                    LineCounter = LineCounter + 1
                End If
            End With
        Next wdLine
    Next wdRectangle
Next wdPage
objDoc.Close SaveChanges:=wdDoNotSaveChanges
    objWord.Quit
End Sub

I also tried the above code but i get activex cant create the object error on the set objdoc line.

 

[oldmanwilly]

HI

Can anyone take a look at this please?

Thanks