Extracting data from Word to Excel

问题

Sub GetFormData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim FmFld As Word.FormField, CCtrl As Word.ContentControl
Dim strFolder As String, strFile As String
Dim 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
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  i = i + 1
  Set wdDoc = wdApp.Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    j = 0
    For Each FmFld In .FormFields
      j = j + 1
      With FmFld
        Select Case .Type
          Case Is = wdFieldFormCheckBox
            WkSht.Cells(i, j) = .CheckBox.Value
          Case Else
            If IsNumeric(FmFld.Result) Then
              If Len(FmFld.Result) > 15 Then
                WkSht.Cells(i, j) = "'" & FmFld.Result
              Else
                WkSht.Cells(i, j) = FmFld.Result
              End If
            Else
              WkSht.Cells(i, j) = FmFld.Result
            End If
        End Select
      End With
    Next
    For Each CCtrl In .ContentControls
      With CCtrl
        Select Case .Type
          Case Is = wdContentControlCheckBox
            j = j + 1
            WkSht.Cells(i, j) = .Checked
          Case wdContentControlDate, wdContentControlDropdownList, wdContentControlRichText, wdContentControlText
            j = j + 1
            If IsNumeric(.Range.Text) Then
              If Len(.Range.Text) > 15 Then
                WkSht.Cells(i, j).Value = "'" & .Range.Text
              Else
                WkSht.Cells(i, j).Value = .Range.Text
              End If
            Else
              WkSht.Cells(i, j) = .Range.Text
            End If 
          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

What the code does is extract the checkbox controls and text controls from a word document to excel using a macro in excel. In my word file, I have a questionnaire that looks like this.

    1.Did you enjoy your day?
    YES ☒
    NO ☐
    Very fun
    2.Would you ever make a trip back? 
    YES ☐
    NO ☒
    Weather was too hot

The code brings in the check box responses but in the format below (Ignore the titles as I created them):

Q1 Yes  Q1 No   Comments    Q2 Yes  Q2 No   Comments
TRUE    FALSE   Very fun    FALSE   TRUE    Weather was too hot

It brings in both check box values into their own column. TRUE meaning check box is checked and FALSE meaning check box is unchecked. I am looking to bring in ONLY the selected answer into ONE column and not as a TRUE/FALSE statement, but as a YES/NO.

I tried using conditional formatting, but when the macro is re-ran, it does not follow the conditional formatting rules, it will just state TRUE/FALSE instead of Yes/No.

7-1-19 - Updated Code:

Sub GetFormData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim FmFld As Word.FormField, CCtrl As Word.ContentControl
Dim strFolder As String, strFile As String
Dim 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
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  i = i + 1
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    j = 0
    For Each FmFld In .FormFields
      With FmFld
        Select Case .Type
          Case Is = wdFieldFormCheckBox
            If .CheckBox.Value = True Then  'Check for true
                 j = j + 1 'Moved after conditional
                 WkSht.Cells(i, j) = "Yes" 'Yes instead of True
            End If
          Case Else
            j = j + 1 'This is no longer at top of loop so you need to continue incrementing
            If IsNumeric(FmFld.Result) Then
              If Len(FmFld.Result) > 15 Then
                WkSht.Cells(i, j) = "'" & FmFld.Result
              Else
                WkSht.Cells(i, j) = FmFld.Result
              End If
            Else
              WkSht.Cells(i, j) = FmFld.Result
            End If
          End Select
      End With
Next
    For Each FmFld In .FormFields
      With FmFld
        Select Case .Type
          Case Is = wdFieldFormCheckBox
         If .CheckBox.Value = True Then 'Check for true
                 j = j + 1 'Moved after conditional
                 WkSht.Cells(i, j) = "Yes" 'Yes instead of True
            End If
          Case Else
            j = j + 1 'This is no longer at top of loop so you need to continue incrementing
            If IsNumeric(FmFld.Result) Then
              If Len(FmFld.Result) > 15 Then
                WkSht.Cells(i, j) = "'" & FmFld.Result
              Else
                WkSht.Cells(i, j) = FmFld.Result
              End If
            Else
              WkSht.Cells(i, j) = FmFld.Result
            End If
          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

With the new code, the macro finishes running but no data is extracted from word to excel.

回答1:

For Each FmFld In .FormFields
      With FmFld
        Select Case .Type
          Case Is = wdFieldFormCheckBox
            if .checkbox.value = True then 'Check for true
                 j = j + 1 'Moved after conditional
                 WkSht.Cells(i, j) = "Yes" 'Yes instead of True
            end if     
          Case Else
            j = j + 1 'This is no longer at top of loop so you need to continue incrementing
            If IsNumeric(FmFld.Result) Then
              If Len(FmFld.Result) > 15 Then
                WkSht.Cells(i, j) = "'" & FmFld.Result
              Else
                WkSht.Cells(i, j) = FmFld.Result
              End If
            Else
              WkSht.Cells(i, j) = FmFld.Result
            End If
          End Select
      End With
Next

That should do it, though I didn't test it as I don't have a word doc with the controls ready to go.

You will also need to apply this to the other loop with checkboxes.

来源：https://stackoverflow.com/questions/56811949/extracting-data-from-word-to-excel

标签

excel

vba

ms-word