エクセルのVBAを使用し、工事写真台帳を作成しています。

エクセルでVBAを使用じ工事写真台帳を作成しています。
まだまだ初心者ですので、なかなか思うようにいきません。詳しい方助けて下さい。

何とか組んで使用できるのですが、一つのセルのみで複数選択する事が出来ません。

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Application.Intersect(Target, Range("B13:F23")) Is Nothing Then Exit Sub
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double
Cancel = True
'===============画像選択
myF = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選択してください(終了)"
Exit Sub
End If
'===============画像の掃除
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'===============画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0) '★ とりあえず 縦横０で。
mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す
'===============タテヨコの縮尺を保持
If mySp.Width > Target.Width Then mySp.Width = Target.Width
If mySp.Height > Target.Height Then mySp.Height = Target.Height
'===============中央へ調整
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2
Set mySp = Nothing
End Sub

上から３行目の(Target, Range("B13:F23"))で、このセルにはダブルクリック、フォルダー選択、写真貼付けができます。
ただ複数選択する事が出来ません。

うまく伝えられず、申し訳ありませんが詳しい方、ご回答宜しくお願い致します。

No.2 回答者： ママチャリ 回答日時： 2018/02/25 09:15

No.1です。

お礼に書かれている回答内容が意味不明ですが・・・。
「選択したファイルを選択したセルに張り付ける」というのが本来の仕様と認識していますが、ダブルクリックでは複数のセルを選択することができません。よって、選択した２つ目以降のファイルの貼り付け先をどうするか、決め事が必要になります。
とりあえず、選択したセルから右へ順に張り付けるサンプルを作ってみました。変更箇所はご自分で確認してください。ご検討をお祈りします。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Application.Intersect(Target, Range("B13:F23")) Is Nothing Then Exit Sub
Dim myF As Variant
Dim myFs As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double
Cancel = True
'===============画像選択
myFs = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , True)
If Not IsArray(myFs) Then
MsgBox "画像を選択してください(終了)"
Exit Sub
End If
For Each myF In myFs
'===============画像の掃除
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'===============画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0) '★ とりあえず 縦横０で。
mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す
'===============タテヨコの縮尺を保持
If mySp.Width > Target.Width Then mySp.Width = Target.Width
If mySp.Height > Target.Height Then mySp.Height = Target.Height
'===============中央へ調整
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2
Set mySp = Nothing
Set Target = Target.Offset(0, 1)
Next myF
End Sub

No.1 回答者： ママチャリ 回答日時： 2018/02/24 20:00

GetOpenFilenameメソッドのMultiSelectオプションにTrueを指定すれば複数ファイルを選択することができるようになります。

しかし、ダブルクリックイベントプロシジャで受け取れるTargetセルは1つのみです。要するに複数のファイルを選択しても貼り付け先のセルが１つしかないので、残りのファイルをどうするか決める必要があります。同じセルに重ねて張りますか？それとも右隣（または下）に貼りますか？

この回答へのお礼

ママチャリさん
回答ありがとうございます。

複数選択は、A4サイズに３枚、４枚と貼り付けたいです。
やはりこのプログラムでは無理ですか？

お礼日時：2018/02/25 04:09