通常であれば、写真・図を貼り付けたい場合はコピーペーストして対応すると思いますが、
貼り付け位置が多い場合や、貼り付けのパターンが多ければコピペでの貼り付けは面倒です。

そこで今回はマクロVBAで変数・配列のように図を格納して好きな位置に

貼り付ける方法を紹介します。
是非参考にしてみてください。それではみていきましょう。

⬛︎忙しい人向けのコピぺ用プログラム

黄色の蛍光ペンの部分をお好みで打ち換えてください。

Sub 図を格納して貼り付け()

Dim WideValue, HighValue, PhotoName As String

For Each TARGET In ActiveSheet.Shapes '写真を繰り返し選択
　If Not Intersect(TARGET.TopLeftCell, Range("切り取り範囲")) Is Nothing And _
　　Not Intersect(TARGET.BottomRightCell, Range("切り取り範囲")) Is Nothing Then
　　　TARGET.Select False '指定範囲に入っていない写真は除外
　End If
Next TARGET

With Selection
　WideValue = .Width '幅を格納
　HighValue = .Height '高さを格納
　.Copy '対象をコピー
End With　

ActiveSheet.ChartObjects.Add(0, 0, WideValue, HighValue).Name = "Targerpicture" 'チャートの作成
ActiveSheet.ChartObjects("Targerpicture").Activate '作成したチャートをアクティブに
ActiveChart.Paste 'チャートに写真を貼り付ける
ActiveChart.ChartArea.Format.Line.Visible = msoFalse 'チャートの外枠をなくす

PhotoName = "保存するパス" & "\" & "貼り付け用写真.jpg"

With ActiveSheet.ChartObjects("Targerpicture")
　.Chart.Export PhotoName '写真を名前をつけて保存
　.Delete
End With

Set OBJSHAPE = ActiveSheet.Shapes.AddPicture( _
　　　　　　　　  FileName:=PhotoName, _
                          LinkToFile:=False, _
　　　　　　　　  SaveWithDocument:=True, _
　　　　　　　　  Left:=ActiveSheet.Range("貼り付け位置").Left, _
　　　　　　　　  Top:=ActiveSheet.Range("貼り付け位置").Top, _
　　　　　　　　  Width:=ActiveSheet.Range("貼り付けサイズ").Width, _
　　　　　　　　  Height:=ActiveSheet.Range("貼り付けサイズ").Height) '貼り付け

Kill PhotoName '写真を消す

End Sub

⬛︎プログラムの考え方について

まず結論から言うと配列や変数などに写真・図を格納することは不可能です。
しかし、似たような事をすることは出来ます。

様々な方法があるのかもしれませんが今回紹介する方法は
写真・図を一旦保存して、そのファイル名を変数に書き込み
その変数を用いて指定位置に貼り付けます。

なので手順としては

①指定範囲内にある写真・図を選択する
②写真・図を保存して、そのパスを変数に格納する
③指定位置に貼り付ける
④プログラム終了後は写真・図ファイルを削除する

と言った流れになります。
では実践編をみていきましょう。

⬛︎実践編:写真・図を格納して貼り付ける方法

では①から④の順に見ていきましょう。

・①指定範囲内にある写真・図を選択する

まずは格納したい写真・図を名前をつけて保存したいと思います。
注意点としてVBAで保存できるのは「Chart」となります。
「Chart」はグラフを意味します。

なのでイメージとして「Chart」を作成して
そこに指定した写真・図を貼り付けて写真・図ごと「Chart」を保存する
といった流れです。

ではまず、保存したい写真・図を選択します。
見本の写真は下図の通りです。

今回は指定範囲内にある写真・図を登録してみましょう。

構文はこちらです。

For Each TARGET In ActiveSheet.Shapes '写真を繰り返し選択

If Not Intersect(TARGET.TopLeftCell, Range("A1:D5")) Is Nothing And _
Not Intersect(TARGET.BottomRightCell, Range("A1:D5")) Is Nothing Then
TARGET.Select False '指定範囲に入っていない写真は除外
End If
Next 
TARGET

今回は見本で「A1からD5」にある写真・図を対象にしました。
なので「Range(“A1:D5”)) Is Nothing」で範囲をしぼっています。

仕組みとして「TopLeftCell」で写真の左上、「BottomRightCell」で写真の右下を検知し、
対象範囲内にあるか確認しています。

その後、範囲内に該当する写真・図については選択した状態を維持するようになります。
実行した結果はこちら。

これで選択は出来ましたが、選択した写真・図を
「Chart」に貼り付ける必要があります。
しかし、通常の状態で「Chart」を生成すると選択した写真・図のサイズとは
異なってしまいます。

そこで現在の写真・図のサイズを格納し、そのサイズに見合った
「Chart」を生成する必要があります。

ではプログラムを見ていきましょう。

Dim WideValue, HighValue

With Selection
WideValue = .Width '幅を格納
HighValue = .Height '高さを格納
.Copy '対象をコピー

End With

現状は対象の写真を選択している状態です。
その選択した写真を対象に「WideValue = .Width」で写真・図の幅を格納し、「HighValue = .Height 」で写真・図の高さを格納します。
さらに貼り付けるため、対象をコピーしています。

では、チャートを作成して、対象の写真を貼り付けてみましょう。
プログラムはこちら

ActiveSheet.ChartObjects.Add(0, 0, WideValue, HighValue).Name = "Targerpicture" 'チャートの作成
ActiveSheet.ChartObjects("Targerpicture").Activate '作成したチャートをアクティブに
ActiveChart.Paste 'チャートに写真を貼り付ける
ActiveChart.ChartArea.Format.Line.Visible = msoFalse 'チャートの外枠をなくす

まずはチャートの作成の構文はこちらです。

ActiveSheet.ChartObjects.Add(左端からの距離, 上端からの距離, 幅, 高さ).Name = "チャートの名前"

左端からの距離と上端からの距離については今回は写真として保存するだけなので
それぞれ「0」とします。
幅と高さについては、先ほど変数に格納した「WideValue」「HighValue」が該当します。

そして今回はチャートの名前を「Targerpicture」としました。
こちらを２行目のプログラムでアクティブ状態にします。

さらに3行目の「ActiveChart.Paste」でチャートに写真を貼り付けます。
そして最後にチャートの外枠を無くしました。外周に黒い線が残ってもいい場合はこちらは省略してください。

ではこれでChart形式の写真・図ができました。

・②写真・図を保存して、そのパスを変数に格納する

ではChart形式で保存できるようになったので、
指定フォルダに保存&変数にパスを格納していきましょう。

プログラムはこのようになります。

Dim PhotoName As String

PhotoName = "C:\検証ファイル\" & "貼り付け用写真.jpg"

With ActiveSheet.ChartObjects("Targerpicture")
.Chart.Export PhotoName
.Delete
End With

では仕組みを紹介します。
現在は①でチャート形式にした写真・図を作成している状態です。

まず変数で写真・図を保存する名前をフルパスを含めて決めています。
つまり、フルパスで指名したフォルダ・ファイル名で一旦
写真・図を保存するようになります。

見本では「ローカルディスクC」の「検証ファイル」に保存して、
写真・図名を「貼り付け用写真」としました。
写真・図なので拡張子を「.jpg」としています。

そして「Chart.Export＋先程のフルパス変数」で
写真・図として保存を実行します。

つまり、このフルパスが入った変数「PhotoName」が
画像を貼り付ける変数になります。

ちなみにここまでのプログラムを実行してみましょう。
指定ファイルにファイルが追加されました。

・③指定位置に貼り付ける

では実際に指定位置に貼り付けてみましょう。
まず構文から紹介したいと思います。

Set OBJSHAPE = ActiveSheet.Shapes.AddPicture( _
FileName:=ここにファイル名, _
LinkToFile:=False, _
SaveWithDocument:=TrueかFalse, _
Left:=左端からの貼り付け位置, _
Top:=上端からの貼り付け位置, _
Width:=写真・図の幅, _
Height:=写真・図の高さ)

では構文に当てはめていきましょう。
まず「FileName」は先程のフルパスが格納された変数「PhotoName」になります。

次に「LinkToFile」ですが図をグラフィック ファイルとリンクするかどうかを指定します。
今回は「False」にします。

「SaveWithDocument」については文書を保存するときに図も一緒に保存するかどうかを指定します。
今回は「True」にしておきましょう。

次に貼り付け位置についてです。
ここでは左端からの貼り付け位置が「Left」、上端からの貼り付け位置が「Top」となります。
ここには数値でもいいですが、セルを指定しても構いません。

今回は見本で「E7」に貼り付けたいと思います。

最後に写真のサイズを指定します。
写真の幅は「Width」、高さは「Height」で指定します。

通常のサイズを維持する場合は「-1」を入力します。
もちろん、直接サイズを入力しても構いません。

今回は見本で「E7」のセルのサイズに合わせて貼り付けます。

すべて足したプログラムはこちらです。

Set OBJSHAPE = ActiveSheet.Shapes.AddPicture( _
FileName:=PhotoName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=ActiveSheet.Range("E7").Left, _
Top:=ActiveSheet.Range("E7").Top, _
Width:=ActiveSheet.Range("E7").Width, _
Height:=ActiveSheet.Range("E7").Height)

・④プログラム終了後は写真・図ファイルを削除する

写真・図を貼り付け終わったら最後に元の状態に戻すため
保存した写真・図を削除します。

削除する構文はこちら。

kill フルパス

では当てはめていきましょう。

フルパスは見本では「PhotoName」に格納しているので
「Kill PhotoName」だけで写真・図ファイルを削除できます。

これで一連の動作は完了です。

・プログラムまとめ

では①から④を組み合わせてみます。
結果はこちらです。

Sub 図を格納して貼り付け()

Dim WideValue, HighValue, PhotoName As String

For Each TARGET In ActiveSheet.Shapes '写真を繰り返し選択
　If Not Intersect(TARGET.TopLeftCell, Range("A1:D5")) Is Nothing And _
　　Not Intersect(TARGET.BottomRightCell, Range("A1:D5")) Is Nothing Then
　　　TARGET.Select False '指定範囲に入っていない写真は除外
　End If
Next TARGET

With Selection
　WideValue = .Width '幅を格納
　HighValue = .Height '高さを格納
　.Copy '対象をコピー
End With　

ActiveSheet.ChartObjects.Add(0, 0, WideValue, HighValue).Name = "Targerpicture" 'チャートの作成
ActiveSheet.ChartObjects("Targerpicture").Activate '作成したチャートをアクティブに
ActiveChart.Paste 'チャートに写真を貼り付ける
ActiveChart.ChartArea.Format.Line.Visible = msoFalse 'チャートの外枠をなくす

PhotoName = "C:\検証ファイル\" & "貼り付け用写真.jpg"

With ActiveSheet.ChartObjects("Targerpicture")
　.Chart.Export PhotoName '写真を名前をつけて保存
　.Delete
End With

Set OBJSHAPE = ActiveSheet.Shapes.AddPicture( _
　　　　　　　　  FileName:=PhotoName, _
                          LinkToFile:=False, _
　　　　　　　　  SaveWithDocument:=True, _
　　　　　　　　  Left:=ActiveSheet.Range("E7").Left, _
　　　　　　　　  Top:=ActiveSheet.Range("E7").Top, _
　　　　　　　　  Width:=ActiveSheet.Range("E7").Width, _
　　　　　　　　  Height:=ActiveSheet.Range("E7").Height) '貼り付け

Kill PhotoName '写真を消す

End Sub

長いですが、これで写真・図を格納して貼り付けるプログラムができました。
では実践してみましょう。

今回は「A1からD5」内の写真・図を格納して
「E7」に貼り付けます。

実行した結果はこちら。

狙い通り、貼り付けることができていますね。
サイズもセルの大きさに合わせて貼り付けてくれています。

⬛︎応用:見本のプログラム

ここからは先程のプログラムを応用したプログラムの事例を紹介します。

・格納した写真・図をブック内の全てのシートに貼り付ける。

まずは写真・図を格納して、ブック内のシート全ての指定位置に
貼り付けてみましょう。

今回は先頭のシートの「A1からD5」の中の写真・図を
他の全てのシートの「E7」に貼り付けるプログラムを見てみましょう。

Sub 図を格納して貼り付け()

Dim WideValue, HighValue, PhotoName As String, SheetNo, cycle

For Each TARGET In ActiveSheet.Shapes '写真を繰り返し選択
  If Not Intersect(TARGET.TopLeftCell, Range("A1:D5")) Is Nothing And _
     Not Intersect(TARGET.BottomRightCell, Range("A1:D5")) Is Nothing Then 
     TARGET.Select False '指定範囲に入っていない写真は除外
  End If
Next TARGET

With Selection
  WideValue = .Width '幅を格納
  HighValue = .Height '高さを格納
  .Copy '対象をコピー
End With

ActiveSheet.ChartObjects.Add(0, 0, WideValue, HighValue).Name = "Targerpicture" 'チャートの作成
ActiveSheet.ChartObjects("Targerpicture").Activate '作成したチャートをアクティブに
ActiveChart.Paste 'チャートに写真を貼り付ける
ActiveChart.ChartArea.Format.Line.Visible = msoFalse 'チャートの外枠をなくす

PhotoName = "C:\検証ファイル\" & "貼り付け用写真.jpg"

With ActiveSheet.ChartObjects("Targerpicture")
  .Chart.Export PhotoName '写真を名前をつけて保存
  .Delete
End With

SheetNo = Sheets.Count

For cycle = 2 To SheetNo Step 1
  Sheets(cycle).Activate
  Set OBJSHAPE = ActiveSheet.Shapes.AddPicture( _
                           FileName:=PhotoName, _
                           LinkToFile:=False, _
                           SaveWithDocument:=True, _
                           Left:=ActiveSheet.Range("E7").Left, _
                           Top:=ActiveSheet.Range("E7").Top, _
                           Width:=ActiveSheet.Range("E7").Width, _
                           Height:=ActiveSheet.Range("E7").Height) '貼り付け
Next cycle

Kill PhotoName '写真を消す

End Sub

「SheetNo」に全体のシート数をカウントして
「For Next」で貼り付けてシート数分貼り付けるようにしています。

通常、シートを繰り返し選択する場合は「For Each 変数 In Worksheets」
を使用しますが、貼り付けるシートを変則的に応用するために
今回はシート番号で対象シートをアクティブにさせています。

⬛︎公式の説明

わかりやすいように説明したため公式と使用する語句が異なりますが
マイクロソフト公式の説明については下記のリンクを参照してください☟

Shapes.AddPicture メソッド (PowerPoint) | Microsoft Learn

⬛︎まとめ

いかがだったでしょうか。
本記事の内容を活用すると、図を変数のように活用することができます。

エクセル内で図を定期的に指定位置に貼り付けたりする際には便利です。
署名の貼り付けなどにも活用できますね！

是非参考にしてみてください。
それでは次回の記事でお会いしましょう。

その中でも容量が大きい写真の軽量化について説明したいと思います。

さらに今回はシート・ブック内すべての写真をまとめて
軽量化できるプログラムを紹介しますので是非参考にしてみてください。

それではみていきましょう！

⬛︎こんなことができる！

シート・ブック内の全ての写真を軽量化することができる

⬛︎忙しい人向けのコピぺ用プログラム

・シート内の写真の軽量化

Sub シート内の画像軽量化()

Dim SelectPictures As Picture '対象の写真
Dim LeftPosition As Double, TopPosition As Double '左端・上端からの距離

For Each SelectPictures In ActiveSheet.Pictures
　If TypeName(SelectPictures) <> "OLEObject" Then
　　SelectPictures.Select
　　LeftPosition=SelectPictures.Left
　　TopPosition=SelectPictures.Top
　　Selection.Cut
　　ActiveSheet.PasteSpecial Format:="図(JPEG)"
　　Selection.Left=LeftPosition
　　Selection.Top=TopPosition
　End If
Next

End Sub

・ブック内の写真の軽量化

Sub ブック内の画像軽量化()

Dim SelectPictures As Picture '対象の写真
Dim LeftPosition As Double, TopPosition As Double '左端・上端からの距離
Dim CycleBook As Worksheet '対象のシート

For Each CycleBook In Worksheets 'シートを繰り返し格納
　CycleBook.Activate 'シートをアクティブ
　　For Each SelectPictures In ActiveSheet.Pictures　
　　If　TypeName(SelectPictures)<>"OLEObject"Then
　　　SelectPictures.Select
　　　LeftPosition=SelectPictures.Left
　　　TopPosition=SelectPictures.Top
　　　Selection.Cut
　　　ActiveSheet.PasteSpecial Format:="図(JPEG)"
　　　Selection.Left=LeftPosition
　　　Selection.Top=TopPosition
　　　EndIf
　Next
Next
End Sub

⬛︎写真が容量が大きい理由

まず、プログラムを紹介するにあたり
なぜ、写真の容量が多いか理解しておきましょう。

見本でフリー素材の図を用意しました。

綺麗ですねー！

では図を拡大してみましょう。

図を拡大してみましょう。

拡大しても画質は綺麗ですね。
実はこの現象が容量増加の原因となります。

原理を説明すると、現在のサイズは写真本来のサイズが100％でなく
現在のサイズ以上の画質を持っていることになります。
言い方を変えれば余分な容量を使っているということになります。

なので今回は現在のサイズに合わせて容量を適正にする方法です。
では本題に移りましょう。

⬛︎図を軽量化するプログラム

ではプログラムを紹介します。
先程の説明で容量の増加の原因は余分な容量を写真が抱えている
ことが原因でした。

解決する方法として対象の図を切り取って再度そのサイズで
図として貼り付けます。そうするとそのサイズに合わせた容量で
貼り付けるので、その差ぶんの容量が減る仕組みです。

プログラムの構造を紹介します。

対象の図.Select
Selection.Cut
ActiveSheet.PasteSpecial Format:=“図 (JPEG)”

では説明です。
1行目の「対象の図.Select」では軽量化したい図を選択します。
2行目の「Selection.Cut」では先程選択した図を切り取ります。
3行目の「ActiveSheet.PasteSpecial Format:=“図 (JPEG)”」
では切り取った写真を今のサイズの容量に合わせて貼り付けます。

これで1つの対象の図を軽量化することができます。
後はブックまたはシート内の全ての写真を繰り返し選択して
上記の処理を行えばいいだけです。

では実践編を見てみましょう。

⬛︎対象シート内の写真を軽量化する

ではこれまでの説明した内容をまとめて
シート内の写真をすべて軽量化してみましょう。

まず、シート内の写真を繰り返し選択するプログラムを紹介します。
プログラムはこちらです。

For Each 変数 In ActiveSheet.Pictures

‘ここに処理プログラム

Next

これでシート内の写真を繰り返し変数に入れていきます。

もう一つ課題があります。
それは選択した写真が「ActiveX」でないことを確認しないといけません。

「ActiveX 」とは開発タブの「挿入」にある「ActiveXコントロール」が
該当します。なぜ、ActiveX出ないことを確認する必要があるかというと
「Pictures 」で繰り返し変数に格納してますが、ActiveXも対象となってしまいます。

さらにActiveXでVBAを動かしている人も多いでしょうから
軽量化にするプログラムを実行するとActiveXが図になってしまうということに
なりかねません。

そこでActiveXか判別できるプログラムは下記のようになります。

If TypeName(変数) <> “OLEObject” Then
’ここに処理内容
End If

条件の「OLEObject」とはActiveXを含むので
OLEObjectでないことを条件として処理します。

さらにもう一つ課題があります。

それは切り取った位置と貼り付けた位置が異なることです。
手動で切り取ってみればわかるのですが、貼り付けの位置は現在選択しているセルになります。

そこで、切り取る前に現在の位置を記録しておき
貼り付けた際には記録した位置に戻す必要があります。

プログラムはこちらです。

左端からの写真の距離変数 = 変数.Left
上端からの写真の距離変数 = 変数.Top

‘ここに写真を切り取って貼り付けるプログラム

Selection.Left = 左端からの写真の距離変数
Selection.Top = 上端からの写真の距離変数

こうなります。
左端・上端からの写真の距離を変数に格納しておき、
貼り付け後に写真の位置を元の位置に戻します。

では総まとめです。
これまでの切り取って写真で貼り付ける、シート内の写真を順次選択する、
写真の位置を元に戻すプログラムを一つにします。

結果はこのようになります。

Sub シート内の画像軽量化()

Dim SelectPictures As Picture '対象の写真
Dim LeftPosition As Double, TopPosition As Double '左端・上端からの距離

For Each SelectPictures In ActiveSheet.Pictures
　If TypeName(SelectPictures) <> "OLEObject" Then
　　SelectPictures.Select
　　LeftPosition=SelectPictures.Left
　　TopPosition=SelectPictures.Top
　　Selection.Cut
　　ActiveSheet.PasteSpecial Format:="図(JPEG)"
　　Selection.Left=LeftPosition
　　Selection.Top=TopPosition
　End If
Next

End Sub

これで完成です。
今回は見本で下図のようなシートを用意しました。

シートの容量を見てみましょう。

「3152KB」と、なかなか大きいですね。

これをプログラムを実行するとこのようになりました。

「288KB」と容量が10倍以上小さくなっていますね。

⬛︎対象ブック内の写真を軽量化する

今度はブック内に範囲を広げましょう。
考え方は先程と同様です。

シート内の写真の軽量化の処理を
ブック内にあるシートすべて繰り返し処理をすれば可能です。

ではブック内のシートをアクティブにする繰り返しプログラムを
紹介したいと思います。

Dim 変数　As Worksheet

For Each 変数 In ThisWorkbook.Worksheets

変数.Activate
’ここに処理
Next

これでアクティブブック内のシート全ての処理ができます。

では先ほどのプログラムに追加してみましょう。
このようになります。

Sub ブック内の画像軽量化()

Dim SelectPictures As Picture '対象の写真
Dim LeftPosition As Double, TopPosition As Double '左端・上端からの距離
Dim CycleBook As Worksheet '対象のシート

For Each CycleBook In Worksheets 'シートを繰り返し格納
　CycleBook.Activate 'シートをアクティブ
　　For Each SelectPictures In ActiveSheet.Pictures　
　　If　TypeName(SelectPictures)<>"OLEObject"Then
　　　SelectPictures.Select
　　　LeftPosition=SelectPictures.Left
　　　TopPosition=SelectPictures.Top
　　　Selection.Cut
　　　ActiveSheet.PasteSpecial Format:="図(JPEG)"
　　　Selection.Left=LeftPosition
　　　Selection.Top=TopPosition
　　　EndIf
　Next
Next
End Sub

これで先ほどシート内の写真を軽量化しましたが
ブック単位で軽量化することができます。

⬛︎公式の説明

わかりやすいように説明したため公式と使用する語句が異なりますが マイクロソフト公式の説明については下記のリンクを参照してください。☟

Worksheet.PasteSpecial メソッド (Excel) | Microsoft Docs

⬛︎注意点

今回紹介した方法は、現在の写真のサイズに合わせて
画質を揃える方法でした。

しかし言い換えると、これまでは拡大しても画質が綺麗だったにも
かかわらず、プログラム実行後は拡大すると画質が悪くなります。

写真を使いまわしたい場合は別のバックアップ等取っておく
必要がありますので、実行の際は気をつけてください。

⬛︎まとめ

いかがだったでしょうか。
エクセルで図を貼り付ける機会がたくさんある方は
ファイルが重くなってないか確認してみてください。

重ければ入力や動作が遅くなる上
添付して送信する際にも時間がかかるなど
いいことはありません。

是非参考にしてみてください
それでは次回の記事でお会いしましょう。