図をセル内に強制的に収める（Shape）

公開日：2013年5月以前　最終更新日：2017-09-02

図をセル内に強制的に収める（Shape）

図（画像等）をエクセルに貼り付けた後、セルの移動と一緒に動かない場合があります。

もちろん、図の書式のプロパティでは、「セルに合わせて移動」にしてある場合の話です。

図がセルを大きくはみ出しているいる場合（隣のセルよりさらにはみだしている場合）は、

セルのコピー、移動にくっていてきません。

また、ソートをする場合は、完全にセル内に入っていないと、一緒にソートされません。

そこで、図をセル内に、すっぽり収めるコードを紹介します。

ここでは、縦横比を保持するようにしています。




Sub ShapesFit()
　　Dim myRange As Range
　　Dim dblScal As 
Double

      　　Dim myShape As Shape
　　For Each myShape In 
ActiveSheet.Shapes
　　　　With myShape
　　　　　　Set myRange = 
.TopLeftCell
　　　　　　.Top = myRange.Top
　　　　　　.Left = 
myRange.Left
　　　　　　If myRange.Width / .Width < myRange.Height / .Height 
Then
　　　　　　　　dblScal = Application.WorksheetFunction.RoundDown(myRange.Width 
/ .Width, 2)
　　　　　　Else
　　　　　　　　dblScal = 
Application.WorksheetFunction.RoundDown(myRange.Height / .Height, 
2)

      　　　　　　End If

      　　　　　　If .LockAspectRatio = msoTrue Then '縦横比固定を判定

　　　　　　　　.ScaleWidth dblScal, msoFalse, msoScaleFromTopLeft

　　　　　　Else

　　　　　　　　.ScaleWidth dblScal, msoFalse, msoScaleFromTopLeft

　　　　　　　　.ScaleHeight dblScal, msoFalse, msoScaleFromTopLeft

      　　　　　　End Ift
　　　　End With
　　Next
End 
Sub

For Each myShape In ActiveSheet.Shapes

シート内の全ての図形に対して、処理します。

.Top = myRange.Top
.Left = myRange.Left
図の左上のセル位置に合わせます。

If myRange.Width / .Width < myRange.Height / .Height Then
　　dblScal = Application.WorksheetFunction.RoundDown(myRange.Width / .Width, 2)
Else
　　dblScal = Application.WorksheetFunction.RoundDown(myRange.Height / .Height, 2)
End If
セル内に収めた場合、縦横の縮小率の小さい方を採用しています。

また、小数以下２桁で切り捨てています。

.ScaleWidth dblScal, msoFalse, msoScaleFromTopLeft
.ScaleHeight dblScal, msoFalse, msoScaleFromTopLeft
同じ比率で、縦横を縮小しています。

実際に使用する場面として考えられるのは、

僅かにはみ出している為、一緒にソートされない場合に、

手作業でやるのが大変な場合とかになるでしょう。

※縦横比を固定している画像の場合に、
　正しくセル内に収まらない事を修正しました。

同じテーマ「マクロVBAサンプル集」の記事

コメントの位置移動と自動サイズ調整とフォント設定
図をセル内に強制的に収める（Shape）
図を確認しながら消していく（Shape）
オートシェイプを他ブックの同じ位置に貼り付ける（Shapes,DrawingObjects）
全シートの画面キャプチャを取得する（keybd_event）
写真の取込方法について（Pictures.Insert,Shapes.AddPicture）
写真をサムネイルに変換して取り込む（Shapes.AddPicture）
円グラフの色設定（Chart,SeriesCollection）
棒グラフ・折れ線グラフのサンプルマクロ
 人口ピラミッドのグラフをマクロで作成
 グラフで特定の横軸の色を変更し基準線を引くマクロ

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門

ホーム
マクロVBA応用編
マクロVBAサンプル集
図をセル内に強制的に収める（Shape）

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.

VBAサンプル集
図をセル内に強制的に収める（Shape）