EXCELで写真帳枠に写真をリサイズして貼り付け後、セル内へ配置に変更するVBAをネット上で公開されているコードを元に作成しましたが正常に動かず困っています。 ---------- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Dim myF As Variant Dim lastPicName As String Dim sh As Shape Cancel = True '==========写真を貼り付けたい範囲の調整をここで行う。 If Not (Target.Columns.Count = 1 And Target.Rows.Count = 13) Then Exit Sub '========== ↑横の結合セル数 ↑縦の結合セル数 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF <> False Then With ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _ SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _ Width:=-1, Height:=-1) '==========タテヨコの縮尺を保持して拡大または縮小 .LockAspectRatio = True '縦横比率の維持(念のため) .Width = Target.Width If .Height > Target.Height Then .Height = Target.Height '==========中央へ調整 .Top = Target.Top + Target.Height / 2 - .Height / 2 .Left = Target.Left + Target.Width / 2 - .Width / 2 End With End If ' 全ての図形をループ処理する For Each sh In ActiveSheet.Shapes ' 図形の種類がピクチャーであるかを確認する If sh.Type = msoPicture Then lastPicName = sh.Name ' 最後のピクチャー名を更新 End If Next sh ActiveSheet.Shapes(lastPicName).Select ActiveSheet.Shapes(lastPicName).PlacePictureInCell End Sub ---------- こちらのコードで「全ての図形をループ処理する」以下で最終ピクチャーネームまでは取得できていてメッセージボックスへ表示させた場合正常に取得できています しかし、Next sh以降の取得したピクチャーネームを使用してセル内へ配置処理をすると数枚貼り付けたところでEXCELが落ち、再起動すると貼り付けはされていますが、セル上に表示へ切り替わっています エラーなどで止まるわけではないので原因が分からずにいます・・・ 識者の方々で原因が分かる方はおられますでしょうか?