Sub pic_take_it()
Dim pic_name As String
Dim pic_cell As Range
'貼り付ける写真とセルの設定
pic_name = "C:\Users\(ユーザー名)\Desktop\picture.jpg" '写真のフルファイルパス
Set pic_cell = ActiveSheet.Range(Cells(2, 3), Cells(3, 5)) '貼り付けたいセル範囲 この場合 Range("C2:E3")と同じ
'貼り付け＆調整マクロを実行
pic_paste pic_name, pic_cell
End Sub
'###### 貼り付け＆調整用呼び出しマクロ######
Sub pic_paste(pic_name As String, pic_cell As Range)
If Dir(pic_name) <> "" Then 'ファイル名が空白でなければ
'写真を元の大きさで貼り付ける
Set myShape = ActiveSheet.Shapes.AddPicture( _
Filename:=pic_name, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=pic_cell.Left, _
Top:=pic_cell.Top, _
Width:=-1, _
Height:=-1)
' ※LinkToFile:=Trueだと、画像リンクのみ作成
'写真をセルの幅に合わせる
With myShape
myHgt = pic_cell.Height 'セルの高さ
myWdt = pic_cell.Width 'セルの幅
mySpH = myShape.Height '写真の高さ
mySpW = myShape.Width '写真の幅
.LockAspectRatio = True
.Top = pic_cell.Top
.Left = pic_cell.Left
'セルと写真の大きさを比べて処理
If myWdt / mySpW < myHgt / mySpH Then
Scal = Application.WorksheetFunction.RoundDown(myWdt / mySpW, 3)
Else
Scal = Application.WorksheetFunction.RoundDown(myHgt / mySpH, 3)
End If
'調整後、ズレることがある（？）ので再度位置調整
.ScaleWidth Scal, msoFalse, msoScaleFromTopLeft
'写真を上下中央に配置
.Top = .Top + (myHgt - myShape.Height) / 2
'写真を左右中央に配置
.Left = .Left + (myWdt - myShape.Width) / 2
End With
End If
End Sub