Excelの表をパワポにひたすらコピペするだけのマクロ組んだ

コピペ作業地味めんどい

データの大切さが叫ばれる今日この頃、Excelを扱う機会が増えた方も多いのではないでしょうか。
pythonでの分析も主流になりつつありますが、まだまだExcelは現役。
ただ、データをまとめて何かで発表する場合、Excelからパワポにひたすらコピペするだけみたいなしんどい作業があったりしませんか。

今回はマクロの勉強もかねて、Excelの表をパワポにひたすらコピペする「コピペボット君」作ってみました。
是非ハンズオンしてみてくださいね。

完成イメージ

ファイルを配置

ファイル配置はこんな感じ。
吐き出す先のパワポは予め新規作成しておいてください。

コピペ元のExcelを「材料」フォルダに格納しておきます。

コピペ元Excelはこんな感じ。

コピペ情報を記入

マクロを仕込んだExcelの中身はこんな感じ。
結構記入する情報が多いですが、毎週毎週同じ作業するとかルーティンが決まっているなら一回作ってしまえばあとは編集する必要はありません。

コピペ完了！

マクロを仕込んだコピペGO!!!ボタンを押すとﾝｺﾞﾝｺﾞコピペが開始されます。
コピペ元のExcelが開いたり閉じたりするのでせわしないですが、待っているだけで完了です。
パワポの保存はされていないので、確認次第保存を忘れないよう気を付けてくださいね。

わーい
コピペ完了後のパワポはこんな感じです。

わーい

実装こまごま

基本のコードはこちらの記事を参考にしました。
ありがとうございましたあああ！！

パワポ用のライブラリをインポート

「ライブラリ」「インポート」という表現があっているのか分かりませんが、私の環境では何もせず実行しようとするとエラーを吐いてしまいました。
どうもパワポ関連のライブラリを使えるようにするよう設定する必要があるとの。
ツールタブの「参照設定」をクリックします。

「Microsoft PowerPoint Object Library」にチェックを入れて「OK」します。これで使えるようになるようです。

名前をクリックするだけではチェックボックスにチェックが入りませんので、ちゃんとチェックが入っているか確認してください。
私はこれで5分ハマりました。

Excelの各行の情報を拾っていく

コピペ情報をひたすら上からブルドーザーしながらセルの中身を読んでいくだけなのでそこまで難しいことはしていません。
今回の場合For文の終わり値をCells(1, 1).End(xlDown).Rowと定義していますが、これはA1セルからctrl+↓をした際にたどり着くセルを示しています。
なので、間に空白行が挟まっている場合途中で止まってしまうことに注意してください。
この辺りはこちらの記事が参考になります。

Dim i
For i = 3 To Cells(1, 1).End(xlDown).Row
	'ひたすら変数定義
	xlsxName = thisWs.Cells(i, 1)
	pathToXlsx = ThisWorkbook.Path & "\材料\" & xlsxName
	sheetName = thisWs.Cells(i, 2)
	copyRangeHidariue = thisWs.Cells(i, 3)
	copyRangeMigishita = thisWs.Cells(i, 4)
	copyRange = copyRangeHidariue & ":" & copyRangeMigishita
	ppSlideNum = thisWs.Cells(i, 5)
	kotei = thisWs.Cells(i, 6)
	koteiCho = thisWs.Cells(i, 7)
	wasContinuous = thisWs.Cells(i - 1, 8)
	isContinuous = thisWs.Cells(i, 8)

	'色んな処理を
	'ここに
	'かく
Next

Excelを新たに開くか判定

ある行でコピペ後、次行のコピペが同一Excelの場合はExcelを閉じる必要はありませんよね。
コード内で処理中の行と次の行のExcelファイル名を比較してif文の条件分岐をするのが普通な気がします、、、が
実装している時の俺は「とりあえずExcelの関数で判定すればいっか」と思ったようです。
どうした俺。全然楽になってないぞ。

if文がExcel内に仕込まれています
「続く」とある場合はExcelを閉じず、次のループでもExcelを開かない、という処理を実装しています。
この辺りはFor文の最後に「Excel閉じて次のを開く」処理を書くなど煩雑にならないような工夫は色々しようがありそうですね。
今回は泥臭く書いてみています。

Dim i
For i = 3 To Cells(1, 1).End(xlDown).Row
        '変数定義を
	'いろいろ
	'します
	
	'前と違うファイルを開く場合
	If wasContinuous <> "続く" Then
	  If Dir(pathToXlsx) <> "" Then
	      Set wb = Workbooks.Open(pathToXlsx)
	  Else
	      MsgBox "ファイルが存在しません。", vbExclamation
	  End If
	End If
	Set ws = wb.Worksheets(sheetName)

	'コピペ処理を
	'ここで
	'します
	
	'次のファイルが違うファイルなら閉じる
        If isContinuous <> "続く" Then
		wb.Save
		wb.Close
		Set wb = Nothing
		Set ws = Nothing
        End If
    Next

コード全体

Sub sample()
    'ppt関連
    Dim ppApp As New PowerPoint.Application
    Dim ppPt As Presentation
    Dim ppSlide As Slide
    Dim ppSlideNum As Integer
    Dim ppShape As PowerPoint.Shape
    Dim pptName As String
    
    'コピペボット君Excel関連
    Dim thisWb As Workbook
    Dim thisWs As Worksheet
    Set thisWb = ThisWorkbook
    Set thisWs = thisWb.Sheets("コピペボット君")
    
    '材料になるExcel関連
    Dim xlsxName As String
    Dim pathToXlsx As String
    Dim sheetName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wasContinuous As String
    Dim isContinuous As String
    
    'コピー関連
    Dim copyRangeHidariue As String
    Dim copyRangeMigishita As String
    Dim copyRange As String
    Dim kotei As String
    Dim koteiCho As Integer
            
　  'パワポを開く	    
    pptName = Cells(3, 10)
    'ppApp.Visible = True 'PowerPoint2007以前の場合は有効にしてください。
    Set ppPt = ppApp.Presentations.Open(ThisWorkbook.Path & "\" & pptName)
    
    'Excelを上から一行ずつブルドーザー
    Dim i
    For i = 3 To Cells(1, 1).End(xlDown).Row
        'ひたすら変数定義
        xlsxName = thisWs.Cells(i, 1)
        pathToXlsx = ThisWorkbook.Path & "\材料\" & xlsxName
        sheetName = thisWs.Cells(i, 2)
        copyRangeHidariue = thisWs.Cells(i, 3)
        copyRangeMigishita = thisWs.Cells(i, 4)
        copyRange = copyRangeHidariue & ":" & copyRangeMigishita
        ppSlideNum = thisWs.Cells(i, 5)
        kotei = thisWs.Cells(i, 6)
        koteiCho = thisWs.Cells(i, 7)
        wasContinuous = thisWs.Cells(i - 1, 8)
        isContinuous = thisWs.Cells(i, 8)
         
        '前と違うファイルを開く場合
        If wasContinuous <> "続く" Then
          If Dir(pathToXlsx) <> "" Then
              Set wb = Workbooks.Open(pathToXlsx)
          Else
              MsgBox "ファイルが存在しません。", vbExclamation
          End If
        End If
        
        Set ws = wb.Worksheets(sheetName)
        
        With ws
            .Range(copyRange).Copy
            DoEvents
            
            'スライド番号を指定
            Set ppSlide = ppPt.Slides(ppSlideNum)
            ppSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=msoFalse
            Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)
            '上位置
            ppShape.Top = Application.CentimetersToPoints(1)
            '左位置
            ppShape.Left = Application.CentimetersToPoints(1)
            '縦横比を固定
            ppShape.LockAspectRatio = msoTrue
            
            If kotei = "高さ" Then
                '横幅
                ppShape.Height = Application.CentimetersToPoints(koteiCho)
            ElseIf kotei = "幅" Then
                '横幅
                ppShape.Width = Application.CentimetersToPoints(koteiCho)
            End If
            Application.CutCopyMode = False
        End With
        
        '次のファイルが違うファイルなら閉じる
        If isContinuous <> "続く" Then
          wb.Save
          wb.Close
          Set wb = Nothing
          Set ws = Nothing
        End If
    Next
    MsgBox ("パワポをご確認の上セーブしてください。")
    
    '保存やウィンドウクローズをする場合ここを有効化
    'ppPt.Save
    'ppApp.Quit
    Set ppPt = Nothing
    Set ppApp = Nothing
End Sub