通过 vba 将数据从 word 传输到 excel

Question

我在 ms word 中有一个表单，其中一些字段是内容控件，一些（是单选按钮）是 ActiveX 控件。我想自动将百字表格传输到 excel 文件。我使用以下 vba 代码：

Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long

myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False

If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True



i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)

While strFile <> ""
    i = i + 1

    Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)

    With myDoc
        j = 0
        For Each CCtl In .ContentControls
            j = j + 1
            myWkSht.Cells(i, j) = CCtl.Range.Text
        Next
        myWkSht.Columns.AutoFit
    End With
    myDoc.Close SaveChanges:=False
    strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True

End Sub

所有数据（文本字段、复选框）都已成功传输，但单选按钮（ActiveX）未传输。

这是单词doc:

这是 excel 结果：

我该如何解决这个问题？

Answer 1

您的单选按钮是内联形状，因此您需要为它们创建一个单独的循环

为了与您当前的代码保持一致，它会像

Dim shp As InlineShape
For Each shp In .InlineShapes
    j = j + 1
    myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp

但是我不想依赖 Word 总是给我正确的顺序，可能还有其他内联形状，所以最好先检查控件：

With myDoc
    'content controls
    For Each CCtl In .ContentControls
        Select Case CCtl.Title
            Case "name"
                myWkSht.Cells(i, 1) = CCtl.Range.Text
            'similar for age and gender
            Case "checkbox1"
                myWkSht.Cells(i, 4) = CCtl.Checked  'true and false are easier to evaluate in Excel than the checkmark symbols
            'same for checkbox 2
        End Select
    Next CCtl

    'option buttons
    For Each shp In .InlineShapes
        If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
            Select Case shp.OLEFormat.Object.Name
                Case "singleSelectQuestionOption1" 'name it something unique
                    myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
                'similar for option button 2
            End Select
        End If
    Next shp
End With

Answer 2

您可以通过名称引用 Word 文档中的 ActiveX 控件

myDoc.singlechoice1.Value

最好用标签名来指代 ContentControls。

myDoc.SelectContentControlsByTag("name").Item(1).Range.Text

重构代码

Sub getWordFormData()
    Dim wdApp As Object, myDoc As Object

    Dim myFolder As String, strFile As String
    Dim i As Long, j As Long

    myFolder = "C:\Users\alarfajal\Desktop\myform"

    If Len(Dir(myFolder)) = 0 Then
        MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Set wdApp = CreateObject("Word.Application")

    With ActiveSheet
        .Cells.Clear
        With .Range("A1:G1")
            .Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
            .Font.Bold = True
        End With

        strFile = Dir(myFolder & "\*.docx", vbNormal)

        i = 1
        While strFile <> ""
            i = i + 1

            Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)

            .Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
            .Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
            .Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
            .Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
            .Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
            .Cells(i, 6).Value = myDoc.singlechoice1.Value
            .Cells(i, 7).Value = myDoc.singlechoice2.Value

            myDoc.Close SaveChanges:=False
            strFile = Dir()
        Wend
        wdApp.Quit

        Application.ScreenUpdating = True
    End With

End Sub

通过 vba 将数据从 word 传输到 excel

transfer data from word to excel via vba

excel

vba

ms-word

activexobject

重构代码