Выбор конкретных элементов управления при извлечении из слова, чтобы преуспеть

Question

Можно ли выбрать, какие конкретные элементы управления формы извлекаются из слова в Excel?

В данный момент у меня есть макрос, который отлично работает и извлекает все элементы управления формой в Excel в одну строку. Дело в том, что мне нужно разбить элементы управления на 3 разных раздела. У каждого свой лист / вкладка. Элементы управления формой - это текстовые и выпадающие списки.

Например: скажем, в форме 9 вопросов.

1-й лист / вкладка, макрос будет тянуть вопросы 1. 2. 3.

2-й лист / вкладка, макрос будет тянуть вопросы (я не против отдельного макроса) 4. 5. 6.

3-й макрос листа / вкладки будет задавать вопросы (я не против отдельного макроса) 7. 8. 9.

Текущий макрос, который отлично работает, но содержит каждый элемент управления:

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

Пример того, как это выглядит. Вопросы повторяются, поэтому не обращайте на них внимания:

Answer 1

Вот схема, чтобы приблизиться к тому, что вы хотите.В основном это все в порядке.Мое решение предполагает, что для каждого элемента управления в вашем документе Word установлено поле Title и определено уникальное значение.

Мое предложение состоит в том, чтобы изолировать аналогично закодированную логику в отдельные функции.Например, SaveControlData и 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