Need help with looping through multiple word documents to excel with VBA

[kmorris]

Hi all!

I have been researching throughout the forum but am trying to create a VBA in excel that will help my business group simplify their process.

For context: we get about 30-50 word documents that are transcripts with different questions and answers every project

For these word documents, I would like to find a way to open up the word document(s) in excel, have it loop through the word document and extract the text into the appropriate column/row


How my word document looks:

Question 1

Answer 1

Question 2

Answer 2

Question 3

Answer 3

SECOND DOCUMENT:

Question 1

Answer 1a

Question 2

Answer 2a

Question 3

Answer 3a

How I need it to look in excel:

Question 1	Question 2	Question 3
Answer 1	Answer 2	Answer 3
Answer 1a	Answer 2a	Answer 3a

I currently have a VBA code that allows me to:
1. have file dialog box open to select the word doc
2. Allows me to get this data from word documents if it is in TABLES in word document, but due to the nature of these word documents, they cannot be in tables. Therefore I need code to parse through these documents based on formatting instead of based on tables.


Here is my current code:

Sub Import_Questions_from_Word()

'declare variables
Dim ws As Worksheet
Dim WordFilename As Variant
Dim Filter As String
Dim WordDoc As Object
Dim tbNo As Long
Dim RowOutputNo As Long
Dim RowNo As Long
Dim ColNo As Integer
Dim tbBegin As Integer
Set ws = ActiveSheet
Filter = "Word File New (*.docx), *.docx," & _
"Word File Old (*.docx), *.docx,"

'displays a Browser that allows you to select the Word document that contains the table(s) to be imported into Excel
WordFilename = Application.GetOpenFilename(Filter, , "Select Word file")
If WordFilename = False Then Exit Sub


'open the selected Word document
Set WordDoc = GetObject(WordFilename)
With WordDoc
tbNo = WordDoc.Tables.Count
If tbNo = 0 Then
MsgBox "This document contains no tables"
End If

'nominate which row to begin inserting the data from. In this example we are inserting the data from row 1

Set tbls = WordDoc.Tables
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To 6
    ws.Cells(lr, i).Value = Application.WorksheetFunction.Clean(tbls(1).Rows(i).Cells(1).Range.Text)
Next

For i = 1 To 25
    ws.Cells(lr, 6 + i).Value = Application.WorksheetFunction.Clean(tbls(2).Rows(i).Cells(1).Range.Text)
Next

WordDoc.Close
Set doc = Nothing
Set sh = Nothing
Set wd = Nothing

End With
End Sub

Appreciate all of your help in advance!