从 word 提取到 excel 时选择特定控件

Question

是否可以选择从word到excel中提取哪些特定的表单控件？

我现在有一个宏，它可以正常工作，并将所有表单控件提取到 Excel 中，放在一行中。问题是，我需要将控件分解为 3 个不同的部分。每个都有自己的工作表/标签。表单控件是文本和下拉列表。

例如：假设表格有 9 个问题。

第一个工作表/标签，宏将提出问题 1. 2. 3.

第二个工作表/标签，宏会提出问题（我不介意单独的宏） 4. 5. 6.

第三个工作表/标签宏将提出问题（我不介意单独的宏） 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