通過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一詞：

這是出色的結果：

我怎么解決這個問題？

Answer 1

您的單選按鈕是inlineshapes，因此您需要一個單獨的循環

為了與您當前的代碼保持一致，它將類似於

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

但是我不想依靠Word總是給我正確的順序，並且可能還有其他inlineshapes，所以最好先檢查一下控件：

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