Excel VBA宏提取Word问卷数据异常：修改后无数据导出求助

Let's break down why your modified macro isn't pulling any data, then adjust it to meet your goal: exporting only selected checkbox options (as YES/NO) in single columns per question, instead of separate columns for each checkbox with TRUE/FALSE.

What's Wrong With the Modified Code? #

• Duplicate FormField Traversal: You're looping through FormFields twice with identical logic. This messes up the column index j and can overwrite or skip data entirely.
• Missing ContentControl Handling: You removed all code that processes Word's modern ContentControl checkboxes. If your questionnaire uses these instead of traditional form fields, no data gets extracted.
• Incorrect Column Index Logic: Your current code increments j only when a checkbox is selected, which would spread answers across random columns instead of mapping each question to a single column.
• Limited File Format Support: You're only searching for .doc files—most modern Word documents use .docx, so you're missing those entirely.

Corrected VBA 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
Dim questionNum As Long, answerText As String

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
' Search for both .doc and .docx files
strFile = Dir(strFolder & "\*.doc*", vbNormal)

While strFile <> ""
    i = i + 1
    ' Record the filename in the first column for reference
    WkSht.Cells(i, 1) = strFile
    Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    j = 1 ' Start from column 2 after filename
    
    With wdDoc
        ' Handle traditional FormField checkboxes and text fields
        questionNum = 0
        For Each FmFld In .FormFields
            With FmFld
                Select Case .Type
                    Case Is = wdFieldFormCheckBox
                        ' Check if this checkbox is part of a new question (based on preceding text)
                        If InStr(.Previous.Text, questionNum + 1 & ".") > 0 Then
                            questionNum = questionNum + 1
                            j = j + 1
                        End If
                        ' Record YES if checked, NO if not (but only keep the selected one)
                        If .CheckBox.Value = True Then
                            answerText = Trim(Split(.Previous.Text, "?")(1))
                            ' Extract YES/NO from the preceding text
                            If InStr(answerText, "YES") > 0 Then
                                WkSht.Cells(i, j) = "YES"
                            ElseIf InStr(answerText, "NO") > 0 Then
                                WkSht.Cells(i, j) = "NO"
                            End If
                        End If
                    Case Else
                        ' Handle text fields (map to next column)
                        j = j + 1
                        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
        
        ' Handle modern ContentControl checkboxes and text fields
        questionNum = 0
        For Each CCtrl In .ContentControls
            With CCtrl
                Select Case .Type
                    Case Is = wdContentControlCheckBox
                        ' Detect new question from preceding text
                        If InStr(.Range.Previous.Text, questionNum + 1 & ".") > 0 Then
                            questionNum = questionNum + 1
                            j = j + 1
                        End If
                        If .Checked = True Then
                            answerText = Trim(Split(.Range.Previous.Text, "?")(1))
                            If InStr(answerText, "YES") > 0 Then
                                WkSht.Cells(i, j) = "YES"
                            ElseIf InStr(answerText, "NO") > 0 Then
                                WkSht.Cells(i, j) = "NO"
                            End If
                        End If
                    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
                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

Key Improvements Explained #

1. Dual Checkbox Support: Restored and optimized handling for both traditional FormField checkboxes and modern ContentControl checkboxes, so no data is missed.
2. Question-to-Column Mapping: Added logic to detect new questions (using the numbered format in your example) and map each question to a single column. Only the selected YES/NO option is recorded for each question.
3. File Format Compatibility: Changed the file search to *.doc* to include both .doc and .docx files.
4. Filename Reference: Added the source Word document filename in the first column of each row for easier tracking.
5. Removed Redundant Code: Got rid of the duplicate FormFields loop to prevent index confusion and redundant processing.

内容的提问来源于stack exchange，提问作者LOZ