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

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

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

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

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

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

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

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

⬛︎注意点

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

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

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

⬛︎まとめ

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

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

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