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

从Word提取到Excel时选择特定控件

1 个答案: