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

我有一个forms在MS单词与一些字段是内容控制和一些（这是单选button）是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 

所有的数据（文本字段，checkbox）都成功传输，但单选button（即ActiveX）不会被传输。

这是doc这个词：

这是最好的结果：

我怎么解决这个问题？

Answer 1

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

myDoc.singlechoice1.Value

最好通过标签名称来引用ContentControls 。

myDoc.SelectContentControlsByTag（ “名”）。项目（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 

Answer 2

你的单选button是inlinehapes，所以你需要一个单独的循环

为了保持你当前的代码，这将是类似的东西

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

然而，我不想依赖Word总是给我正确的顺序，并且可能有其他的内联forms，所以最好先检查控件：

 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