マクロで帳票を作成するときに、データと一緒に画像も貼り付けたいという要望はあると思います。
本記事では、Excel で画像を貼り付けるマクロを作成しました。具体的には、画像をそのまま貼り付けるだけのマクロと、範囲が指定されたときに幅や高さを合わせるマクロを作成しています。
目次
画像の大きさを変えずに指定の場所に貼り付けるマクロ
マクロを作るためには画像が必要ですが、貼り付ける画像がないという方は、いらすとやさんの画像を以下からダウンロードしてください!
参考 意識の低い人のイラスト(男性)いらすとや以下のソースでは画像をここ↓に保存している前提です!
“C:\Users\Public\Documents\ishiki_hikui_man.png”
VBAのソースコードを書く
ソースコードを書いていきましょう。処理内容はソースのコメントに書いてあります。
なおこのソースは以下のサイトを参考にさせてもらってます。
参考 画像ファイルを挿入するmougモーグcopy
Public Sub PastePicture1()
Dim sheet As Worksheet
Dim filePath As String
Dim targetRange As Range
Dim picture As Shape
Dim targetRangeHeight, targetRangeWidth As Single
' シートを指定する
Set sheet = ActiveSheet
' ファイルパス
filePath = "C:\Users\Public\Documents\ishiki_hikui_man.png"
' 貼り付ける範囲を指定する
Set targetRange = Range("B2")
' ExcelのB2セルに合わせて図を挿入する
Set picture = sheet.Shapes.AddPicture( _
fileName:=filePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=targetRange.Left, _
Top:=targetRange.Top, _
Width:=0, _
Height:=0)
' 挿入した図を元の大きさにする
With picture
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
End Sub
ソースコードの解説
画像をExcelの指定の場所に貼り付ける
画像を貼り付ける位置を設定しているのは、Shapes.AddPictureメソッドのLeftとTopパラメーターです。
名前 | データ型 | 説明 |
---|---|---|
Left | Single | 文書の左上隅を基準にして図の左上隅の位置をポイント単位で指定します。 |
Top | Single | 文書の左上隅を基準にして図の左上隅の位置をポイント単位で指定します。 |
上のソースコードでは、LeftとTopパラメーターをB2セルのLeftとTopに設定しているので、ExcelのB2セルに合わせて画像が貼り付けられます。
そのため、画像を貼り付ける場所を変更したい場合には、Set targetRange = Range(“B2”) のB2を変更してください。
参考 Shapes. AddPicture メソッド (Excel)Microsoft Docs画像をそのままの大きさで貼り付ける
ShapesオブジェクトのScaleWidthとScaleHeightメソッドを使用します。Factor = 1、RelativeToOriginalSize = msoTrueに設定することで、図をそのままの大きさで貼り付けられます。
名前 | データ型 | 説明 |
---|---|---|
Factor | Single | 現在の高さと変更後の高さの比率、または元の高さと変更後の高さの比率を指定します。 たとえば、四角形を 50% 拡大する場合は、この引数に 1.5 を指定します。 |
RelativeToOriginalSize | MsoTriState | 元のサイズを基準にして図形を拡大または縮小する場合は msoTrue 。 現在のサイズを基準にして拡大または縮小する場合は msoFalse を指定します。 msoTrue を指定できるのは、図形が図または OLE オブジェクトのときだけです。 |
マクロを実行する
キーボードの【F5】を押す、または画面上部の【▶】を押して、マクロを実行します。
ExcelのB2セルの左上に合わせてに画像が表示されていれば完了です!
画像の大きさを指定範囲に合わせながら貼り付けるマクロ
ただ、マクロで画像を貼り付けたいという場合には、貼り付ける範囲が決まっていることもあるでしょう。
僕が経験した仕事には、毎回大きさが異なる画像を、指定した範囲(例えばB2:F13)に貼り付けるようなものがありました。イメージを以下にしめすと、「左の図の大きさを良い感じに枠の中に納まるようにして、右の図のようにしたい」という感じです。
仕様の説明
まずは、画像を貼り付ける仕様の説明をします。
- 指定範囲よりも画像の縦横両方が小さい場合には、指定範囲の中央に画像を貼り付けます(①)
- 指定範囲よりも画像の縦の方が大きい場合には、縦方向を指定範囲と同じ大きさにして、横方向の中心に画像を貼り付けます(②)
- 指定範囲よりも画像の横の方が大きい場合には、横方向を指定範囲と同じ大きさにして、縦方向の中心に画像を貼り付けます(③)
①~③を図に示すと、以下のようになります。
VBAのソースコードを書く
ソースコードは以下になります。
copy
Public Sub PastePicture2()
Dim sheet As Worksheet
Dim filePath As String
Dim targetRange As Range
Dim picture As Shape
Dim targetRangeHeight, targetRangeWidth As Single
' シートを指定する
Set sheet = ActiveSheet
' ファイルパス
filePath = "C:\Users\Public\Documents\ishiki_hikui_man.png"
' 貼り付ける範囲を指定する
Set targetRange = Range("B2:H22")
targetRangeWidth = targetRange.Width
targetRangeHeight = targetRange.Height
' 図を挿入する
Set picture = sheet.Shapes.AddPicture( _
fileName:=filePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)
' 挿入した図を元の大きさにして、縦横比を固定する
With picture
.LockAspectRatio = msoTrue
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
' 画像の大きさを設定する
With picture
' 指定範囲の左上に仮置きする
.Left = targetRange.Left
.Top = targetRange.Top
' 指定範囲よりも画像の縦横両方が小さい場合
If .Width < targetRangeWidth And .Height < targetRangeHeight Then
.Left = .Left + (targetRange.Width - .Width) / 2
.Top = .Top + (targetRange.Height - .Height) / 2
Else
' 画像の幅を指定範囲に仮設定する
.Width = targetRangeWidth
'
If .Height > targetRangeHeight Then
.Height = targetRangeHeight
.Left = .Left + (targetRange.Width - .Width) / 2
Else
.Top = .Top + (targetRange.Height - .Height) / 2
End If
End If
End With
End Sub
ごりごりと処理を書いているので、あまり説明できる部分はないのですが、このソースのポイントとしては、Shape.LockAspectRatioプロパティをTrueにしている箇所です。
Shape.LockAspectRatioとは、図の縦横比を一定にするプロパティで、これを設定することで、画像がゆがまないようになっています。
参考 Shape.LockAspectRatio プロパティ (Excel)Microsoft Docsマクロを実行する
キーボードの【F5】を押す、または画面上部の【▶】を押して、マクロを実行します。
仕様の説明の①のように画像が貼り付けられれば成功です!
なお罫線(黒い線)は、分かりやすいように筆者は手動で書きました。自動的に書かれないのでご注意ください。
ここまで完成したら、ソースコード内の範囲を指定する箇所を変更して、きちんと仕様通りに動くか確認してみるといいでしょう。
範囲をしていしているのは、ソースコード内の以下の部分になります。H22をF10にしたり、E20に変更すれば仕様の動きを確認できます。
Set targetRange = Range(“B2:H22”)