Wordでアンケートを作り、Excelで集計する

Option Explicit

Public Sub アンケート結果集計()

    Dim objWord As Word.Application
    Dim objFso As FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim docxFolderPath As String
    
    Dim outputList As ListObject
    
    
    Set objWord = New Word.Application
    objWord.Visible = False
    
    Set objFso = New FileSystemObject
    
    ' 結果フォルダパスの取得
    docxFolderPath = ThisWorkbook.Path & "\結果"
    
    ' 結果を集めるテーブルを取得
    Set outputList = Sheet1.ListObjects("テーブル1")
    
    ' リストを空にする
    Do While outputList.ListRows.Count > 0
        outputList.ListRows(1).Delete
    Loop
    
    ' 結果フォルダにあるWordファイルを開く
    If Not objFso.FolderExists(docxFolderPath) Then
        MsgBox "結果フォルダがありません"
        objWord.Quit SaveChanges:=False
        Set objWord = Nothing
        Exit Sub
    End If
    
    Set objFolder = objFso.GetFolder(docxFolderPath)
    
    For Each objFile In objFolder.Files
        Call ファイルごとの処理(objWord, objFile.Path, outputList)
    Next
    
    objWord.Quit
    Set objWord = Nothing
    
    MsgBox "結果を集め終わりました", vbInformation

End Sub

Private Sub ファイルごとの処理(ByRef objWord As Word.Application, filePath As String, ByRef outputList As ListObject)

    Dim objDoc As Word.Document
    Dim objControl As Word.ContentControl
    
    Dim newRow As ListRow
    Dim fileNameIndex As Integer
    

    If LCase(Right(filePath, 4)) <> "docx" Then
        Exit Sub
    End If

    Set objDoc = objWord.Documents.Open(filePath, ReadOnly:=True)
    
    ' リストに1行追加
    Set newRow = outputList.ListRows.Add()
    
    ' ファイル名をリストに追加
    fileNameIndex = GetColumnIndex(outputList, "ファイル名")
    newRow.Range(fileNameIndex) = objDoc.Name

    ' コントロールの値を集める
    For Each objControl In objDoc.ContentControls
        Call コントロールごとの処理(objControl, outputList, newRow)
    Next

    objDoc.Close SaveChanges:=False

End Sub

Private Sub コントロールごとの処理(ByRef objControl As Word.ContentControl, ByRef outputList As ListObject, ByRef newRow As ListRow)
    
    Dim columnIndex As Integer
    
    ' コントロールのタイトルがリストの列にあるか調べる
    columnIndex = GetColumnIndex(outputList, objControl.Title)
    
    If columnIndex < 0 Then
        Exit Sub
    End If
    
    ' コントロールの種類に合わせて値を取得
    If objControl.Type = wdContentControlCheckBox Then
        newRow.Range(columnIndex) = objControl.Checked
    Else
        newRow.Range(columnIndex) = objControl.Range.Text
    End If
    
End Sub

' 列名から列インデックスを取得する
Private Function GetColumnIndex(ByRef outputList As ListObject, columnName As String) As Integer
    Dim objColumn As ListColumn
    
    GetColumnIndex = -1
    
    For Each objColumn In outputList.ListColumns
        If objColumn.Name = columnName Then
            GetColumnIndex = objColumn.Index
            Exit Function
        End If
    Next
    
End Function