VBAノック79本目：Wordにセル範囲を図として挿入

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：Wordにセル範囲を図として挿入
ソースコード
解説

出題：Wordにセル範囲を図として挿入

#VBA100本ノック 79本目
ブックと同一フォルダにdoc1.docxがあります。
ブックマーク「エクセル表」の位置から、
・ブック名
・シート名
・A1セルからの表をリンクしない図で貼り付け
同一フォルダに「doc1_yyyymmdd.docx」で保存してWord終了してください。
※完成は画像を参照
※シートは任意

Wordファイルサンプル

◇ 出題ページはこちら

ソースコード

' 100本ノック079：Wordにセル範囲を図として挿入
Sub 表を図として挿入してWordファイルを更新する()
    
    ' コピー元のオブジェクトを取得
    Dim Rangeコピー元 As Range
    Set Rangeコピー元 = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
    Dim wbコピー元 As Workbook: Set wbコピー元 = Rangeコピー元.Parent.Parent
    Dim wsコピー元 As Worksheet: Set wsコピー元 = Rangeコピー元.Parent
    
    ' 対象のWordファイルを開く
    Dim Wordアプリ As Word.Application
    Set Wordアプリ = CreateObject("Word.Application")
    
    Dim doc貼付先 As Word.Document
    Set doc貼付先 = Wordアプリ.Documents.Open(wbコピー元.Path & "\doc1.docx")
    
    ' 貼り付け先のブックマークをWordのRangeオブジェクトに取得(なければExit)
    If doc貼付先.Bookmarks.Exists("エクセル表") = False Then Exit Sub
    Dim WordRange貼付先 As Word.Range
    Set WordRange貼付先 = doc貼付先.Bookmarks("エクセル表").Range
    
    ' ブック名とシート名を挿入
    WordRange貼付先.Text = wbコピー元.Name & vbVerticalTab _
                                      & wsコピー元.Name & vbCr
    WordRange貼付先.Collapse Direction:=0
    
    ' 表をリンクしない図として貼り付け
    Rangeコピー元.Copy
    WordRange貼付先.PasteSpecial _
        Link:=False, _
        DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine
    Application.CutCopyMode = False
    
    ' 対象のWordファイルを保存して終了
    doc貼付先.SaveAs2 Replace(doc貼付先.FullName _
        , ".docx", Format(Date, "_yyyymmdd") & ".docx")
    doc貼付先.Close False
    Wordアプリ.Quit
    
End Sub