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

Question

我在ms中有一个表单，其中一些字段是内容控件，而一些字段（单选按钮）是ActiveX控件。我想自动将100个单词表单传输到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

你的radiobuttons是inlineshapes所以你需要一个单独的循环

要与当前代码保持一致，它就像

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（＆＃34;名称＆＃34）。（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