[[20171001024913]]　『【EXCEL VBA】挿入した画像のファイル名を隣のセメx（七瀬しおり）　ページの最後に飛ぶ

『【EXCEL VBA】挿入した画像のファイル名を隣のセルに自動で表示したい』（七瀬しおり）

はじめまして。ご訪問ありがとうございます。
VBA初心者です。ただいまエクセルを使用し、下記の様な写真リストを作成しております。

　　A(種別)　　　B(画像)　　C(ファイル名)

1　　　海　　　　画像01　　　01.JPG
2　　　山　　　　画像02　　　02.JPG
3　　　空　　　　画像03　　　03.JPG
.
.
.
10　　花　　　　画像10　　　10.JPG

B列のセル上でダブルクリックすると、[ファイルを開く]ダイアログボックスが表示され、選択した画像（複数可）がセルの大きさに自動でリサイズされ貼り付けられる仕様です。
そこに、画像の隣のセルに自動でファイル名を取得し表示する機能を追加したいのですが、上手く行かなくて困っております。
今のマクロにどの様に追記すれば良いか教えていただきたく、どうぞよろしくお願いいたします。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myFs As Variant
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
If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
Cancel = True

'画像選択コマンド
myFs = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , True)
If IsArray(myFs) = False 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
'タテヨコの縮尺を保持
myHH = Target.Height / mySp.Height
myWW = Target.Width / mySp.Width
If myHH > myWW Then
mySp.Height = mySp.Height * myWW
mySp.Width = Target.Width
Else
mySp.Height = Target.Height
mySp.Width = mySp.Width * myHH
End If
'センター中心に配置
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(1)
Next myF

End Sub

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

 きちんとインデントをつけるべきです。

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
     Dim myFs As Variant
     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

     If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub

     Cancel = True
     '画像選択コマンド
     myFs = Application.GetOpenFilename _
            ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , True)
     If IsArray(myFs) = False 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

         'タテヨコの縮尺を保持
         myHH = Target.Height / mySp.Height
         myWW = Target.Width / mySp.Width
         If myHH > myWW Then
             mySp.Height = mySp.Height * myWW
             mySp.Width = Target.Width
         Else
             mySp.Height = Target.Height
             mySp.Width = mySp.Width * myHH
         End If

         'センター中心に配置
         myHH2 = (Target.Height / 2) - (mySp.Height / 2)
         myWW2 = (Target.Width / 2) - (mySp.Width / 2)
         mySp.Top = Target.Top + myHH2
         mySp.Left = Target.Left + myWW2

         ' ここに追加 ====================
         'Target.Offset(0, 1).Value = myF    ' フルパス
         Target.Offset(0, 1).Value = Dir(myF) 'ファイル名

         Set mySp = Nothing
         Set Target = Target.Offset(1)
     Next myF
 End Sub

（γ） 2017/10/01(日) 04:16

γ様
この度はお忙しい中ご丁寧にご教示いただきまして、ありがとうございました！
インデントの付け方までご指導いただき、とても見やすいコードになり感謝いたします。
自分であれこれ格闘しておりましたが、γ様のコードで理解することができました。
また機会がございましたら、よろしくお願いいたします。

（七瀬しおり） 2017/10/01(日) 04:32

コメント返信：

[ 一覧(最新更新順) ]

[[20171001024913]] 『【EXCEL VBA】挿入した画像のファイル名を隣のセメx（七瀬しおり） ページの最後に飛ぶ

[[20171001024913]]　『【EXCEL VBA】挿入した画像のファイル名を隣のセメx（七瀬しおり）　ページの最後に飛ぶ