セル範囲に合わせて図形(Shape)を拡大・縮小する

セル範囲に合わせて図形(Shape)を拡大・縮小する方法を解説します。

セル範囲と同じサイズにする場合は、RangeオブジェクトのTop/Left/Width/HeightをShapeオブジェクトに代入します。

セル範囲にぴったり合わせて拡大・縮小する

まずは図形をセル範囲と同じ位置・同じサイズにするコードです。

Sub セル範囲に合わせて図形を拡大縮小する()
    
    Dim 対象図形 As Shape
    Set 対象図形 = ActiveSheet.Shapes("Picture 1")
    
    Dim 移動先セル範囲 As Range
    Set 移動先セル範囲 = ActiveSheet.Range("B2:E10")
    
    ' 縦横比を解除
    対象図形.LockAspectRatio = msoFalse
    
    ' 位置とサイズをセル範囲に合わせる
    対象図形.Left = 移動先セル範囲.Left
    対象図形.Top = 移動先セル範囲.Top
    対象図形.Width = 移動先セル範囲.Width
    対象図形.Height = 移動先セル範囲.Height
    
End Sub

このように、図形のLeft/Top/Width/Heightプロパティに、
セル範囲の同名プロパティをそのまま代入すればOKです。

このコードでは図形の縦横比を無視してセル範囲にぴったり合わせるため、
先にLockAspectRatioへmsoFalseを指定しています。

画像などで縦横比を変えたくない場合は、次セクションのコードを使用してください。

なお、選択中の図形を対象にする場合は以下のように取得します。

Set 対象図形 = Selection.ShapeRange(1)

SelectionそのものをShape変数にSetしようとすると、
「型が一致しません」エラーになりますのでご注意ください。

縦横比を保ったままセル範囲内に収める

画像などをセル範囲内に収めたい場合は、
縦横比を固定したまま幅または高さのどちらか一方をセル範囲に合わせます。

Sub 縦横比を保ってセル範囲内に図形を収める()
    
    Dim 対象図形 As Shape
    Set 対象図形 = ActiveSheet.Shapes("Picture 1")
    
    Dim 移動先セル範囲 As Range
    Set 移動先セル範囲 = ActiveSheet.Range("B2:E10")
    
    ' 縦横比を取得
    Dim 図形縦横比 As Double
    図形縦横比 = 対象図形.Width / 対象図形.Height
    
    Dim セル範囲縦横比 As Double
    セル範囲縦横比 = 移動先セル範囲.Width / 移動先セル範囲.Height
    
    ' 縦横比を固定
    対象図形.LockAspectRatio = msoTrue
    
    ' セル範囲内に収まるよう拡大・縮小
    If 図形縦横比 > セル範囲縦横比 Then
        対象図形.Width = 移動先セル範囲.Width
    Else
        対象図形.Height = 移動先セル範囲.Height
    End If
    
    ' 余白を取得
    Dim 幅余白 As Double
    幅余白 = 移動先セル範囲.Width - 対象図形.Width
    Dim 高さ余白 As Double
    高さ余白 = 移動先セル範囲.Height - 対象図形.Height
    
    ' セル範囲の中央に配置
    対象図形.Left = 移動先セル範囲.Left + 幅余白 / 2
    対象図形.Top = 移動先セル範囲.Top + 高さ余白 / 2
    
End Sub

こちらは図形とセル範囲の縦横比を比較し、
幅に合わせるべきか、高さに合わせるべきかを判定しています。

LockAspectRatioにmsoTrueを指定しているため、
WidthまたはHeightのどちらか一方を変更すれば、
もう片方のサイズは縦横比を保ったまま自動で変更されます。

その後、余白を求めてからそれを2で割り、
セル範囲の中央に配置しています。

このコードはセル範囲内に図形全体を収めるコードですので、
セル範囲ぴったりにはならず、上下または左右に余白ができます。

画像の縦横比を崩したくない場合はこちらを使用してください。

汎用関数化

この処理をよく使う場合は、汎用関数にしておくと便利です。

セル範囲にぴったり合わせる

' 図形 → セル範囲にぴったり合わせる
Sub 図形をセル範囲に合わせる(対象図形 As Shape, 移動先セル範囲 As Range)
    
    ' 縦横比を解除
    対象図形.LockAspectRatio = msoFalse
    
    ' 位置とサイズをセル範囲に合わせる
    対象図形.Left = 移動先セル範囲.Left
    対象図形.Top = 移動先セル範囲.Top
    対象図形.Width = 移動先セル範囲.Width
    対象図形.Height = 移動先セル範囲.Height
    
End Sub

　
▼ 使用例

Call 図形をセル範囲に合わせる( _
        ActiveSheet.Shapes("Picture 1"), ActiveSheet.Range("B2:E10"))

縦横比を保ったままセル範囲内に収める

' 図形 → 縦横比を保ってセル範囲内に収める
Sub 図形を縦横比固定でセル範囲内に収める(対象図形 As Shape, 移動先セル範囲 As Range)
    
    ' 縦横比を取得
    Dim 図形縦横比 As Double
    図形縦横比 = 対象図形.Width / 対象図形.Height
    
    Dim セル範囲縦横比 As Double
    セル範囲縦横比 = 移動先セル範囲.Width / 移動先セル範囲.Height
    
    ' 縦横比を固定
    対象図形.LockAspectRatio = msoTrue
    
    ' セル範囲内に収まるよう拡大・縮小
    If 図形縦横比 > セル範囲縦横比 Then
        対象図形.Width = 移動先セル範囲.Width
    Else
        対象図形.Height = 移動先セル範囲.Height
    End If
    
    ' 余白を取得
    Dim 幅余白 As Double
    幅余白 = 移動先セル範囲.Width - 対象図形.Width
    
    Dim 高さ余白 As Double
    高さ余白 = 移動先セル範囲.Height - 対象図形.Height
    
    ' セル範囲の中央に配置
    対象図形.Left = 移動先セル範囲.Left + 幅余白 / 2
    対象図形.Top = 移動先セル範囲.Top + 高さ余白 / 2
    
End Sub

　
▼ 使用例

Sub 縦横比を保ってセル範囲内に図形を収める()
    
    Call 図形を縦横比固定でセル範囲内に収める( _
        ActiveSheet.Shapes("Picture 1"), ActiveSheet.Range("B2:E10"))
    
End Sub

　
両方ともメインコードが1行になってかなりスッキリしましたね。

セル範囲に図形を合わせるコード自体は短いですが、
Width/Height/Top/Leftの4つを毎回書くのは地味に面倒です。

また、縦横比を固定するコードは、
縦横比判定や中央配置の計算が入るため、メインコードに直接書くと少し読みづらくなります。

このように「簡単だけど書くのが面倒なコード」は、
関数化が簡単な割に、汎用関数にするメリットが大きいです。

汎用関数集を作っている方は、ぜひそのメンバーに加えてあげてください。

汎用関数のつくり方についてはこちらの記事をどうぞ。