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

kmorris

New Member
Joined
Jul 14, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
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 1Question 2Question 3
Answer 1Answer 2Answer 3
Answer 1aAnswer 2aAnswer 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:

VBA 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!
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Forum statistics

Threads
1,141,075
Messages
5,704,162
Members
421,331
Latest member
imdumb

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top