エクセルを使って、トレーニング名に応じて画像を自動切換表示させたい

質問

Sheet1に、トレーニング名、説明文、画像（jpgファイル名）等の項目を作り、100件以上のレコードが入っている表があります。

Sheet2に、上記の3レコード（＝3トレーニング）分のデータをA4用紙に見やすく配置したフォーム（？）を作り、VLOOKUP関数を使って、データを表示させるようにしました。（つまりAトレーニングのトレーニング番号を選ぶとAトレーニングのデータが、Bトレーニングのトレーニング番号を選ぶとBトレーニングのデータが表示）

この時、一つ目のレコードについては画像を表示させることができたのですが、２つめ以降のレコードについては画像を表示させることができません。

以下のコードを作成しています。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
On Error GoTo ER:
If Target.Address <> "$C$3" Then Exit Sub
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$3" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E3").Left, .Range("E3").Top, 160, 120)
End With

If Target.Address <> "$C$15" Then Exit Sub
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$15" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E15").Left, .Range("E15").Top, 160, 120)
End With

If Target.Address <> "$C$27" Then Exit Sub
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$27" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E27").Left, .Range("E27").Top, 160, 120)
End With
ER:
End Sub

ハイパーリンクのように他に飛んで表示させるのではなく、エクセルのその場所に表示させたいと思います。（3トレーニング分をA4用紙で印刷したいと思います）

ちなみに画像は、エクセルファイルの置いてある下（サブフォルダ）にまとめて入れております。宜しくお願い致します。

回答No.1

onlyrom · ベストアンサー

>２つめ以降のレコードについては画像を表示させることができません。

コードをじっくり追っていけば直ぐ気づくはずですが。。(^^;;;

>If Target.Address <> "$C$3" Then Exit Sub

このコードで、セルＣ３以外は終了になりますよね？
残り２つのセルＣ１５，Ｃ２７は、何もしないでExit Subへ、ということです。

質問者のコードをそのまま使って修正すると、

'-------------------------------------------

If Target.Address = "$C$3" Then

　　・・１つ目の処理・・・

ElseIf Target.Address = "$C$15" Then

　　・・２つ目の処理・・・

ElseIf Target.Address = "$C$27" Then

　　・・３つ目の処理・・・　

End If

'----------------------------------------------

このように、IF～ElseIF～ 構文を使います。
もちろん、Select Case文とかも使えます。

●ただ、１つ目、２つ目、３つ目で変るところは、セルアドレスだけですので、
そこを上手く利用するとよりシンプルなコードになります。

例えば、以下のように。。

'---------------------------------------------------------　
Private Sub Worksheet_Change(ByVal Target As Range)

　Dim fName As String, pict As Shape
　On Error GoTo ER:

　If Target.Address = "$C$3" Or _
　　　Target.Address = "$C$15" Or _
　　　Target.Address = "$C$27" Then

　　　fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Value
　　　If Dir(fName) = "" Then
　　　　　fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
　　　End If

　　　For Each pict In ActiveSheet.Shapes
　　　　If pict.TopLeftCell.Address = Target.Offset(0, 1).Address Then
　　　　　　pict.Delete
　　　　　　Exit For
　　　　End If
　　　Next pict

　　　Set pict = ActiveSheet.Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　　Target.Offset(0, 1).Left, Target.Offset(0, 1).Top, 160, 120)

　End If

ER:
End Sub
'-----------------------------------------------------------

以上。

お礼

onlyromさんへ

すばやいご回答、本当にありがとうございます。

ご指示頂いたようにVBAを修正してみました。
すると、トレーニングAの横の画像は出て
いるのですが、トレーニングB、Cの画像が
それぞれのセルに表示されません。
(トレーニングB、Cの選択により、トレーニ
ングAの画像が切り替わってしまいます)

トレーニングAの画像はE3
トレーニングBの画像はE15
トレーニングCの画像はE27

のようにそれぞれ画像表示したいと思っています。
=============================================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
On Error GoTo ER:
If Target.Address <> "$C$3" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$3" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E3").Left, .Range("E3").Top, 160, 120)
End With

　(2つ目は文字制限上省略しています)

ElseIf Target.Address <> "$C$27" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$27" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E27").Left, .Range("E27").Top, 160, 120)
End With

End If

ER:
End Sub
=============================================================

回答No.7

onlyrom

何度目の登場でしょうか、onlyromです。

＞ちなみに入力規制というものが大きな原因になっていたということですが

そうです、入力規則のドロップダウンリストを使うと、
Drop Down というコントロールがシートに１つ貼りつきます。

ところがこれは、
If pict.TopLeftCell.Address = "$E$3" Then

この、TopLeftCellプロパティを持っていませんし
表面上表示されてないコントロールなので
そのコードがエラーとなるわけです。

で、それを回避するために

　　If Left(pict.Name, 7) = "Picture" Then
　　　　If pict.TopLeftCell.Address = "$E$3" Then

"Picture"、即ち画像だったら、TopLeftCellを訊く、としているわけです。

これで説明になっていますか？

＞こういうものを作ればお客様も喜ぶし、
＞仕事も簡素化されると思いやっていたのですが、

何事においてもそのような姿勢は非常に大切なことだと思います。
また分からないことがあったら遠慮なく質問してください。
ykdreamさんのように頑張っている人には誰もが親切に回答してくれることでしょう。
以上。

お礼

onlyromさん

　遅い時間までありがとうございました。
　最後まで本当にご丁寧にありがとうございました。

　ドロップダウンリストが行く手を阻んでいたことが
　わかりました。私の基礎的知識が不足していますが、
　概要はつかめました。

　今回onlyromさんのような方に出逢えて本当に良かった
　です。

　明日の目覚めが最高の予感がします。
　では、おやすみなさい。

回答No.6

onlyrom

いまさっき帰宅、晩御飯食べて、早速チェック。

やはり実際のものを見るのが一番ですね。
最初の質問に、番号を入れて、Vlookupと書いてあったので
てっきり、番号を手入力しているのかと。。。
まさか、入力規則を使ってるとは思いもしませんでした。

原因はその入力規則です。
理由の説明が必要ですか？

ともあれ、いままでのを破棄して、下記コードに入れ替えて実行してください。
お望みどおりに動くはずです。

'---------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape

If Target.Address = "$C$3" Then
　　fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
　　If Dir(fName) = "" Then
　　　　fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
　　End If
　　With ActiveSheet
　　For Each pict In .Shapes
　　　　If Left(pict.Name, 7) = "Picture" Then
　　　　　　If pict.TopLeftCell.Address = "$E$3" Then
　　　　　　　　pict.Delete
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next pict
　　Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　　　　　.Range("E3").Left, .Range("E3").Top, 160, 120)
　　End With

ElseIf Target.Address = "$C$15" Then
　　fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
　　If Dir(fName) = "" Then
　　　　fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
　　End If
　　With ActiveSheet
　　For Each pict In .Shapes
　　　　If Left(pict.Name, 7) = "Picture" Then
　　　　　　If pict.TopLeftCell.Address = "$E$15" Then
　　　　　　　　pict.Delete
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next pict
　　Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　　　　　.Range("E15").Left, .Range("E15").Top, 160, 120)
　　End With

ElseIf Target.Address = "$C$27" Then
　　fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
　　If Dir(fName) = "" Then
　　　　fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
　　End If
　　With ActiveSheet
　　For Each pict In .Shapes
　　　　If Left(pict.Name, 7) = "Picture" Then
　　　　　　If pict.TopLeftCell.Address = "$E$27" Then
　　　　　　　　pict.Delete
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next pict
　　Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　　　　　.Range("E27").Left, .Range("E27").Top, 160, 120)
　　End With

End If

End Sub
'----------------------------------------------------

それから、一番最初に言ったように、
３セルの処理とも９９％同じ処理ですからひとつに纏めた方がいいでしょう。
そうすれば修正も一箇所ですみますから。
暇を見つけてそういうコードに変更することをお奨めします。
以上。

お礼

onlyromさんへ

　喜びのあまり、叫んでしまいました！！
　動きました！！動きました！！！

　お食事も束の間、チェックして頂いてありがとうござ
　いました。onlyromさんが懇切丁寧にご指導してくれた
　お陰です。ほんとうにありがとうございました。

　こういうものを作ればお客様も喜ぶし、仕事も簡素化
　されると思いやっていたのですが、visual　basicは
　初心者で、なかなか前に進みませんでした。

　大きく前に進めました！ありがとうございました。

　ちなみに入力規制というものが大きな原因になっていた
　ということですが、もし理由をご説明して頂けるので
　したら宜しくお願いします。

　一つに纏めたコードについては自分で変更していって
　みようと思います。

回答No.5

onlyrom

またまたまた登場、onlyromです。

テストの時はOn Errorを外しておくと今回のように上手くいかない原因が明らかになることがあります。

いま補足など読んでみましたが、？？？という感じですので、帰宅してからまた考えてみたいと思います。

●一番確実なのは、質問のブックをYahooブリーフケースなどにアップして公開してもらうことです。
もしくは、当方にメール添付していただければ。。。

何れにしろ同じコードで当方では上手くいってるわけですから、あっさりと解決するはずです。

乗りかかった船、解決するまでお付き合いする所存でございまする。
大船（泥舟？？）に乗った気持ちでお待ちくだされ。。。(^^;;;
以上。

お礼

onlyromさんへ

大船にのっている実感があります。

Yhaooブリーフケースに公開しています。
ほんとにほんとにお手数をおかけしますが
宜しくお願いします。

http://briefcase.yahoo.co.jp/bc/mpfnm247/lst?&.dir=/3aae&.src=bc&.view=l

ykdreamより

回答No.4

onlyrom

またまた登場、onlyromです。

＞お忙しいとは思いますが、コメントよろしくお願いします。

忙しくないので、コメントします。。。(^^;;;

＞しかし、まだトレーニングB、Cの横に画像がでてきません

こういうときはも少しはっきりと書かないといけません。
画像自体が出てこないのか、
画像は出るが、ちゃんと決まった場所に出ないのか、など。

コードを一見したところおかしいとこはないようなので、
同じ条件のテストデータで実行してみたところちゃんと動作しました。

で、信用してないわけではないのですが、
質問者が修正したコードは破棄して、
当方がテストした下記コードで実行してみてください。

ブックはコピーして、それを使うというでしょう。　

'-------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape

●●● ''On Error GoTo ER:　　これは省いておくこと

If Target.Address = "$C$3" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$3" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E3").Left, .Range("E3").Top, 160, 120)
End With

ElseIf Target.Address = "$C$15" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$15" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E15").Left, .Range("E15").Top, 160, 120)
End With

ElseIf Target.Address = "$C$27" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$27" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E27").Left, .Range("E27").Top, 160, 120)
End With

End If

ER:
End Sub
'---------------------------------------------

テストのときは、●●のOn Error は省いておくのがベターです。

以上。

お礼

onlyromさんへ

　ご丁寧なご指示にほんとに感謝です。

　現在のエラー状況を説明します。
　１)ご指示いただいたコードをそのままコピペしました。
　　(On Error は省きました)

　２)シートにおいて、トレーニングA部分でトレーニング
　　　内容を選択をすると、一度は画像が出現するのです
　　　が、2回目以降別内容のトレーニングを選択すると、
　　　エラーメッセージが出て画像が変更されません。

　　　～エラーメッセージ～
　　　実行時エラー"1004"
　　　アプリケーション定義またはオブジェクト定義のエラーです

　　　visual　basicのウィンドウを確認すると、
　　　以下の部分が黄色で選択されています。
　　　If pict.TopLeftCell.Address = "$E$3" Then

　３)トレーニングB部分、トレーニングC部分には、画像が何も
　　　表示されていない状態です。(ちなみに、トレーニングB、
　　　C部分は、VLOOKUP関数により内容を選択するごとにImage
　　　ファイル名も連動しています。)　　　

　以上です。

　ほんとにほんとに長いことお付き合いをして頂いて恐縮です。
　ありがとうございます。

補足

onlyromさんへ

　エラー状況の追記です。

　トレーニングB、C部分で画像が出ておりませんが、
　トレーニング内容を選択するとエラー状況2)と同
　様のエラーメッセージが出てしまいます。

回答No.3

redfox63

If Target.Address = "$C$3" Then
ElseIf Target.Address = "$C$15" Then
ElseIf Target.Address = "$C$27" Then
の次の行にブレークポイントを設定して実行してみましょう

C15,C27が変更された際にブレークされるか確認し、F8でステップ実行してみましょう

回答No.2

onlyrom

再度の登場、onlyromです。

回答をちゃんと見てますか？(^^;;;

先の回答は、

　　If Target.Address ●＝● "$C$3" Then

と、比較演算子は、　＝　ですが、

質問者の修正したコードは、

　　If Target.Address ■<>■ "$C$3" Then

＝　ではなく、＜＞　のままですよね？

そこを修正して実行してください。
以上。

お礼

onlyromさんへ

ご指摘ありがとうござました。〈〉→＝に修正しました。
大変失礼しました。

この結果、トレーニングB、Cの選択によりトレーニングAの
画像が切り替わることはなくなりました。しかし、まだトレー
ニングB、Cの横に画像がでてきません。。。まだ修正すべき
点を私が見落としているのでしょうか？

お忙しいとは思いますが、コメントよろしくお願いします。
=============================================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
On Error GoTo ER:
If Target.Address = "$C$3" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$3" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E3").Left, .Range("E3").Top, 160, 120)
End With

　(2つ目は文字制限上省略しています)

ElseIf Target.Address = "$C$27" Then
fName = ThisWorkbook.Path & "\Image\" & Target.Offset(0, 1).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$E$27" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("E27").Left, .Range("E27").Top, 160, 120)
End With

End If

ER:
End Sub
=============================================================