Selecting specific controls when extracting from word to excel - excel

Question

Is it possible to select which specific form controls are extracted from word to excel?
I have a macro at the moment that works fine and extracts all the form controls into excel, onto one single row. The thing is, I need to break down the controls into 3 different sections. Each having its own sheet/tab. The form controls are text and drop down lists.
For example: Say the form has 9 questions.
1st worksheet/tab, macro will pull questions
1.
2.
3.
2nd worksheet/tab, macro will pull questions (I don't mind a separate macro)
4.
5.
6.
3rd worksheet/tab macro will pull questions(I don't mind a separate macro)
7.
8.
9.
Current macro that runs great, but brings in every single control:
Sub GetFormData()
'Note: this code requires a reference to the Word object model
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, CCtrl As Word.ContentControl
Dim strFolder As String, strFile As String, WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
With CCtrl
Select Case .Type
Case Is = wdContentControlCheckBox
j = j + 1
WkSht.Cells(i, j).Value = .Checked
Case wdContentControlDate, wdContentControlDropdownList, wdContentControlRichText, wdContentControlText
j = j + 1
WkSht.Cells(i, j).Value = .Range.Text
Case Else
End Select
End With
Next
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Example of what it looks like. The questions are repeated so dont mind them:

Answer 1

Here 's an outline to approach what you want. Basically it's all in the set up. My solution assumes that each control in your Word document has the Title field set and defined to a unique value.
My suggestion is to isolate similarly coded logic into separate functions. As an example, the SaveControlData and IsInArray.
Option Explicit
Sub example()
Dim thisSheet As Worksheet
Dim thatSheet As Worksheet
Dim theOtherSheet As Worksheet
Set thisSheet = ThisWorkbook.Sheets("Sheet1")
Set thatSheet = ThisWorkbook.Sheets("Sheet2")
Set theOtherSheet = ThisWorkbook.Sheets("Sheet3")
'--- map the control (by Title) to each worksheet
Dim thisTitles As Variant
Dim thatTitles As Variant
Dim theOtherTitles As Variant
thisTitles = Split("MyCheckbox,MyTextbox", ",")
thatTitles = Split("MyDatebox", ",")
theOtherTitles = Split("MyCheckbox,MyDatebox", ",")
Dim wdApp As Word.Application
Set wdApp = New Word.Application
Dim wdDoc As Word.Document
Set wdDoc = wdApp.Documents.Open("C:\Temp\Test text.docx")
'--- determine the starting point for data on each worksheet
Dim thisCell As Range
Dim thatCell As Range
Dim theOtherCell As Range
Set thisCell = thisSheet.Range("A1") 'calculate last row?
Set thatCell = thatSheet.Range("A1")
Set theOtherCell = theOtherSheet.Range("A1")
Dim CCtrl As Word.ContentControl
With wdDoc
For Each CCtrl In .ContentControls
'--- arranging the If statements like this means you could
' technically copy the same control value to different
' worksheets
If IsInArray(thisTitles, CCtrl.Title) Then
SaveControlData thisCell, CCtrl
thisCell.Offset(0, 1).value = CCtrl.Title
Set thisCell = thisCell.Offset(1, 0)
End If
If IsInArray(thatTitles, CCtrl.Title) Then
SaveControlData thatCell, CCtrl
thatCell.Offset(0, 1).value = CCtrl.Title
Set thatCell = thatCell.Offset(1, 0)
End If
If IsInArray(theOtherTitles, CCtrl.Title) Then
SaveControlData theOtherCell, CCtrl
theOtherCell.Offset(0, 1).value = CCtrl.Title
Set theOtherCell = theOtherCell.Offset(1, 0)
End If
Next CCtrl
End With
wdDoc.Close SaveChanges:=False
wdApp.Quit
End Sub
Private Function IsInArray(ByRef wordList As Variant, ByVal thisWord As String) As Boolean
IsInArray = False
Dim i As Long
For i = LBound(wordList, 1) To UBound(wordList, 1)
If wordList(i) = thisWord Then
IsInArray = True
Exit Function
End If
Next i
End Function
Private Sub SaveControlData(ByRef cell As Range, ByRef CCtrl As Variant)
With CCtrl
Select Case .Type
Case Is = wdContentControlCheckBox
cell.value = .Checked
Case wdContentControlDate, _
wdContentControlDropdownList, _
wdContentControlRichText, _
wdContentControlText
cell.value = .Range.Text
Case Else
End Select
End With
End Sub