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

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

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

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

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

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

実施した結果

そう！こんな感じです。強いて言えば、左上だけで良かったかもしれませんが、中身をこれからいじって行く上で大した手間ではありません。

むしろ１００ページ分の見出しスライドを作ってくれただけで大感謝です。

---

 

■プロフィール

■開業したいドクター向けの動画販売

■開業ドクターを支援する士業等向けの動画販売

■相続相談

■社長向け（税務顧問・セカンドオピニオン）

---