【エクセル】名称を参照し画像を表示する

質問

いつも大変お世話になっております。

前回【エクセル】元データシートよりマクロで表を複数作成の件、
ご教示いただき、ありがとうございました。

元データシートよりマクロで表を複数作成した後、
各シートごとB1の名称を参照し、それに一致する画像をB5に表示することを
考えています。

いろいろ試してみたもののうまくいかず、質問させていただきました。

よろしくお願いいたします。

回答No.3

HohoPapa · ベストアンサー

課題ブック格納フォルダーの下階層にjpgフォルダーがあり、
ここに拡張子jpgのファイル群があり
B2セルに拡張子無しのファイル名が埋まっている前提です。
前提が違えば指摘してください。

Sub Sample1()
　Dim JpgPath As String　　 '画像格納フォルダー
　Dim ShCounter As Long　　 'sheetカウンター
　Dim ShCount As Long　　　 'シート総数
　Dim JpgFName As String　　'JPegファイルフルパス

　With ThisWorkbook
　　JpgPath = .Path & "\Jpg\"
　　ShCount = .Sheets.Count
　　For ShCounter = 1 To ShCount
　　　With .Sheets(ShCounter)
　　　　JpgFName = JpgPath & .Cells(1, 2).Value & ".jpg"　'ファイル名組立
　　　　If .Cells(1, 2).Value = "" Then
　　　　　MsgBox ("ファイル名の指定がありません。/") & ShCounter & "シート目"
　　　　　Exit For
　　　　End If
　　　　If FileExists(JpgFName) = False Then
　　　　　MsgBox ("ファイルがありません。/") & ShCounter & "シート目"
　　　　　Exit For
　　　　End If
　　　　.Select
　　　　.Cells(5, 2).Select　　　　　　　　　　　'貼り付け位置選択
　　　　.Pictures.Insert JpgFName　　　　　　　　'貼り付け
　　　End With
　　Next ShCounter
　End With
End Sub

'//------------------------------------------------------------------------------------------------
'//　ファイル有無判定関数
'//------------------------------------------------------------------------------------------------
Function FileExists(ChkFile As String) As Boolean
　FileExists = True
　On Error GoTo ErrorHandler　　　　 ' エラー処理ルーチンを定義
　FileDateTime (ChkFile)
　On Error GoTo 0　　　　　　　　　　' エラーのトラップを無効にします。
　Exit Function　　　　　　　　　　　' エラー処理ルーチンが実行されないように Sub を終了
ErrorHandler:　　　　　　　　　　　　' エラー処理ルーチン
　FileExists = False
　Resume Next
End Function

お礼

HohoPapa様
ご回答ありがとうございます。参考にし、試してみます。
よろしくお願いいたします。

回答No.4

HohoPapa

シート上の画像を貼りかえることを考慮し
画像を貼る前に、
シート上の画像（Shape）を全数削除するようにしてみました。
剥がしたくないShapeがあるようなら指摘してください。

Sub Sample1()
　Dim JpgPath As String　　 '画像格納フォルダー
　Dim ShCounter As Long　　 'sheetカウンター
　Dim ShCount As Long　　　 'シート総数
　Dim JpgFName As String　　'JPegファイルフルパス

　With ThisWorkbook
　　JpgPath = .Path & "\Jpg\"
　　ShCount = .Sheets.Count
　　For ShCounter = 1 To ShCount
　　　With .Sheets(ShCounter)
　　　　JpgFName = JpgPath & .Cells(1, 2).Value & ".jpg"　'ファイル名組立
　　　　If .Cells(1, 2).Value = "" Then
　　　　　MsgBox ("ファイル名の指定がありません。/") & ShCounter & "シート目"
　　　　　Exit For
　　　　End If
　　　　If FileExists(JpgFName) = False Then
　　　　　MsgBox ("ファイルがありません。/") & ShCounter & "シート目"
　　　　　Exit For
　　　　End If
　　　　Do '画像（Shapes）があったら全数削除
　　　　　If .Shapes.Count = 0 Then Exit Do
　　　　　.Shapes(1).Delete
　　　　Loop
　　　　.Select
　　　　.Cells(5, 2).Select　　　　　　　　　　　'貼り付け位置選択
　　　　.Pictures.Insert JpgFName　　　　　　　　'貼り付け
　　　End With
　　Next ShCounter
　End With
End Sub

'//------------------------------------------------------------------------------------------------
'//　ファイル有無判定関数
'//------------------------------------------------------------------------------------------------
Function FileExists(ChkFile As String) As Boolean
　FileExists = True
　On Error GoTo ErrorHandler　　　　 ' エラー処理ルーチンを定義
　FileDateTime (ChkFile)
　On Error GoTo 0　　　　　　　　　　' エラーのトラップを無効にします。
　Exit Function　　　　　　　　　　　' エラー処理ルーチンが実行されないように Sub を終了
ErrorHandler:　　　　　　　　　　　　' エラー処理ルーチン
　FileExists = False
　Resume Next
End Function

回答No.2

imogasi

>いろいろ試してみたもののうまくいかず、
どういうＶＢＡコードを作って、うまく行かなかったのか、質問に書くべきだろう。
その点を書かないで、思わせぶりな質問するパターンが多いが、困ったものだ。
この部分は書かない方がまし。
また＞前回【エクセル】・・のお礼の部分も、不要だろう。
（写真画像のファイ名がわかっていて）シートにその画像（多分写真画像？）を表示する、はＧｏｏｇｌｅで、照会すればすぐ分かる。それさえもやってないのでは。
この対応データは、シートにデータとして持って置くほうがよいとおもうが、その点がどうするのかな。
ーー
全般的に、一例で
https://www.moug.net/tech/exvba/0120020.html　等の
Set myShape = ActiveSheet.Shapes.AddPicture( _・・
のAddPicture　はどうか。
ーー
すでに回答が出ているが、もっと込み入った内容か？

お礼

imogasi様
ご指摘ありがとうございます。参考にさせていただきます。

回答No.1

watabe007

それぞれの画像は "C:\Users\xxxxxx\Pictures\"
に B1の名称.jpg で有るものとしています。
Sub Test()
　　Const PicPath As String = "C:\Users\xxxxxx\Pictures\"
　　Dim objShape As Shape

　　If Range("B1").Value = "" Then Exit Sub
　　Set objShape = ActiveSheet.Shapes.AddPicture( _
　　　　Filename:=PicPath & Range("B1").Value & ".jpg", _
　　　　LinkToFile:=False, _
　　　　SaveWithDocument:=True, _
　　　　Left:=0, Top:=0, Width:=0, Height:=0)
　　With objShape
　　　　.LockAspectRatio = True
　　　　.Locked = False
　　　　.Left = Range("B5").Left
　　　　.Top = Range("B5").Top
　　　　.Width = Range("B5").Width
　　End With
End Sub

お礼

watabe007様、
ありがとうございます。参考にいたします。