Extracting questions/answers from word doc to excel

Hi all!

I am working on automating and simplifying some processes on my business team, and could use some help with this macro.

Context: we do text analysis on interview questions. There are about give or take 20 questions per interview, depending on the project. They are recorded, sent to a transcription service, and come back to us in word documents. We need to get the contents of the transcript into columns in the excel sheet, with the question being the column header.

For inserting the questions as the header I have a simple fix: put the questions into a table and have a macro read the table.

The problem is that I need to come up with a macro to read the answers in these transcripts based on formatting, rather than being in a table. We can have anywhere from 30-50 transcripts per project and multiple projects at at time, so it's not feasible to copy and paste.

Here is a photo for reference: the question will be bolded, and the answer will be below.
We need it to go into the excel as seen just below that.

Capture.PNG

Here is my current code as far as I have it:

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. 

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

Thanks in advance!

Assume each question has two answers and the word file saved at the same location of the excel file and named "Question.docx".

Sub test()
    Dim i%, k%, j%, m%, wdApp, wdf, str$, arr()
    Application.DisplayAlerts = False
    str = ThisWorkbook.Path & "\"
    k = 1: j = 1: m = 0
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = False
    Set wdf = wdApp.documents.Open(str & "Question.docx")
    For i = 1 To wdf.Paragraphs.Count
        If wdf.Paragraphs(i).Range.Font.Bold Then
            ReDim Preserve arr(1 To 3, 1 To k)
            arr(1, k) = wdf.Paragraphs(i).Range.Text
            m = m + 1: j = 2: k = k + 1
        Else
            arr(j, m) = wdf.Paragraphs(i).Range.Text
            j = j + 1
        End If
    Next
    Sheet1.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    Application.DisplayAlerts = True
End Sub