Wordの見出しをPowerPointの見出しに転記してくれるVBAマクロをChatGPTに質問した結果

2023年5月31日

Wordの見出しをPowerPointの見出しの転記を手で行うのは面倒

見出しのとおりですが、Wordで作成した見出しを手でコピペするのは大変時間がかかります。

上のような章、節、項に分けているようなことを

PowerPointのマクロで自動でやってくれないかChatGPTに質問しました。下記が回答とコードです。ご丁寧にVBAマクロを有効にする設定まで案内してくれます。

■WEB開催セミナー4/20：2025　歯科クリニック開業で伝えたいこと
■沢田慎次郎のプロフィール
個別コンサルティング
動画販売
最新刊『インボイスの教科書』
税務顧問・税務相談

ChatGPTの回答

Sub ConvertWordHeadingsToPowerPoint()
Dim wdApp As Object
Dim wdDoc As Object
Dim wdRange As Object
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptShape As Object
Dim headingLevel As Integer

' ワード文書を開く
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open("C:\path\to\your\word\document.docx")

' パワーポイントを開く
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add

' ワードの見出しをパワーポイントの見出しに変換する
For Each wdRange In wdDoc.Range.Paragraphs
    ' 見出しのスタイルを判別する
    Select Case wdRange.Style
        Case "Heading 1"
            headingLevel = 1
        Case "Heading 2"
            headingLevel = 2
        Case "Heading 3"
            headingLevel = 3
        ' 必要に応じて、他の見出しスタイルを追加します
    End Select

    ' パワーポイントの新しいスライドに見出しを追加する
    Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, 11)
    Set pptShape = pptSlide.Shapes.AddTextbox(1, 50, 50, 500, 50)
    pptShape.TextFrame.TextRange.Text = wdRange.Range.Text
    pptShape.TextFrame.TextRange.Font.Size = 24
    pptShape.TextFrame.TextRange.Font.Bold = True
    pptShape.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
    pptSlide.Shapes.Title.TextFrame.TextRange.Text = wdRange.Range.Text
    pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 24
    pptSlide.Shapes.Title.TextFrame.TextRange.Font.Bold = True
    pptSlide.Shapes.Title.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
    pptSlide.Layout = 1 + headingLevel '

    pptSlide.Layout = 1 + headingLevel ' スライドのレイアウトを適切な見出しレベルに設定する
Next wdRange

' ワードとパワーポイントを閉じる
wdDoc.Close SaveChanges:=False
wdApp.Quit
pptPres.SaveAs "C:\path\to\save\your\powerpoint\presentation.pptx"
pptPres.Close
pptApp.Quit

' リリース
Set pptShape = Nothing
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
Set wdRange = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing

End Sub