ワードのヘッダーとフッターを出力する

ワードのヘッダーとフッターを出力する

Sub CopyWordHeaderFooterToExcel()
    Dim wdApp As Object ' Word.Application
    Dim wdDoc As Object ' Word.Document
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlWS As Excel.Worksheet
    Dim i As Integer
    Dim wordFilePath As String
    
    ' ワードファイルを選択
    wordFilePath = Application.GetOpenFilename("Word files (*.doc; *.docx), *.doc; *.docx", , "Select Word file")
    If wordFilePath = "False" Then
        MsgBox "No file selected.", vbExclamation
        Exit Sub
    End If
    
    ' エクセルアプリケーションの起動
    Set xlApp = New Excel.Application
    xlApp.Visible = True ' エクセルを表示するかどうか
    
    ' 新しいワークブックを作成
    Set xlWB = xlApp.Workbooks.Add
    
    ' 新しいワークシートを取得
    Set xlWS = xlWB.Sheets(1)
    
    ' Wordアプリケーションの起動
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    ' Wordドキュメントを開く
    Set wdDoc = wdApp.Documents.Open(wordFilePath)
    
    ' ヘッダーをコピー
    For i = 1 To wdDoc.Sections(1).Headers.Count
        With wdDoc.Sections(1).Headers(i)
            CopyTextToExcel .Range, xlWS.Cells(i, 1)
        End With
    Next i
    
    ' フッターをコピー
    For i = 1 To wdDoc.Sections(1).Footers.Count
        With wdDoc.Sections(1).Footers(i)
            CopyTextToExcel .Range, xlWS.Cells(i + wdDoc.Sections(1).Headers.Count, 1)
        End With
    Next i
    
    ' 後処理
    wdDoc.Close False
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    
    MsgBox "Word header and footer contents have been copied to Excel successfully.", vbInformation
End Sub

Sub CopyTextToExcel(rngSource As Object, rngDestination As Object)
    ' テキストをエクセルにコピーする補助関数
    rngDestination.Value = rngSource.Text
End Sub