Attribute VB_Name = "xls2ppt"
Option Explicit

Sub copyContents()
    Const figName = "図 1"  'エクセルからコピペする図の名前
    Const tblName = "targetTable"  '更新対象のPPTの表の名前
    Const ttlName = "targetTitle"  '更新対象のタイトルの名前
    
    Const xPos = 0  'ｐｐｔに図を貼り付ける水平位置（ｃｍ）
    Const yPos = 3.15  'ｐｐｔに図を貼り付ける垂直位置（ｃｍ）
    
    Dim ppApp As Object:    Set ppApp = CreateObject("PowerPoint.Application")
    If ppApp.Visible = 0 Then errorEnd ("貼り付け先のPPTを開いてから実行してください。")
    Dim tarPP As Object:    Set tarPP = ppApp.ActivePresentation
    
    '前月の図を削除する
    Call PowerPointの図を全消しする(tarPP)
    
    'サブルーチン用変数を用意　スライド番号
    Dim sh As Long, tarSld As Long, mRange As range 'pptへ転記するテーブル
    
    Const tarCol = "B"
    Const titleTblRow = 3
    Const reportTblRow = 22
    
    Dim strLastMonth As String:     strLastMonth = (12 + Month(Now) - 2) Mod 12 + 1 '前月を
    
    'Title
    sh = 1:       tarSld = 2
    Set mRange = Worksheets(sh).Cells(titleTblRow, tarCol).CurrentRegion        'Worksheets(1).Cells(3, "B").CurrentRegion.Copyはやめた
    Call PowerPointの表を更新(tarPP, mRange, tarSld, tblName)
      
    Dim rpNum As Long
    For rpNum = 1 To 3  'Report1 CPU使用率     'Report2 空きメモリ容量   'Report3 ディスク使用率
        '図の更新    '
        sh = sh + rpNum: tarSld = tarSld + rpNum    '対象シート、対象スライドを変更
        Worksheets(sh).Shapes(figName).Copy
        Call PowerPointの図を貼り付ける(tarPP, tarSld, xPos, yPos)
        
        '表の更新
        Set mRange = Worksheets(sh).Cells(reportTblRow, tarCol).CurrentRegion
        Call PowerPointの表を更新(tarPP, mRange, tarSld, tblName)
            
        'タイトルの更新【●月レポート】
        Call PowerPointのタイトルを更新(tarPP, tarSld, ttlName, strLastMonth)
    Next rpNum
End Sub

Sub PowerPointの表を更新(tarPP, mRange As range, tarSld As Long, tblName As String)
    Dim rCnt As Long: rCnt = mRange.Rows.Count
    Dim cCnt As Long: cCnt = mRange.Columns.Count
    Dim Gyo As Long, Retsu As Long
    For Gyo = 1 To rCnt
        For Retsu = 1 To cCnt
           tarPP.slides(tarSld).Shapes(tblName).Table.cell(Gyo, Retsu).Shape.TextFrame.TextRange.text = mRange(Gyo, Retsu).text
        Next Retsu
    Next Gyo
End Sub

Sub PowerPointのタイトルを更新(tarPP, tarSld As Long, ttlName As String, strLastMonth As String)
    With tarPP.slides(tarSld).Shapes(ttlName)
        tarPP.slides(tarSld).Select
        .TextFrame.TextRange.text = "【" & strLastMonth & "月レポート】"
    End With
End Sub

Sub PowerPointの図を貼り付ける(tarPP, tarSld As Long, xPos As Double, yPos As Double)
    With tarPP.slides(tarSld).Shapes.Paste
        'コピー元の位置に移動
        .Left = xPos * 72 / 2.54
        .Top = yPos * 72 / 2.54
        .ZOrder msoSendToBack
    End With
End Sub

Sub PowerPointの図を全消しする(tarPP)
    Const debugFlag = 0
    Dim figType As Long '.ActivePresentation.Slides(sld).Shapes(shp).Type
    Dim sld As Long, eSld As Long
    Dim shp As Long, eShp As Long
    eSld = tarPP.slides.Count
    For sld = 1 To eSld
        eShp = tarPP.slides(sld).Shapes.Count
        For shp = eShp To 1 Step -1
            If debugFlag > 0 Then Debug.Print "sld=" & sld & " shp=" & shp & " |" & tarPP.slides(sld).Shapes(shp).Type
            figType = tarPP.slides(sld).Shapes(shp).Type
            If figType = 13 Or figType = 1 Then '13:グラフ、1:シェイプ
                tarPP.slides(sld).Shapes(shp).Delete
            End If
        Next shp
    Next sld
End Sub
 

Private Sub errorEnd(msg)
    MsgBox msg
    End
End Sub