解決済みの質問

質問No.4038194
すぐに回答を!
すぐに回答を!
お気に入り投稿に追加する (1人が追加しました)
回答数7
閲覧数297
エクセルを使って、トレーニング名に応じて画像を自動切換表示させたい
Sheet1に、トレーニング名、説明文、画像(jpgファイル名)等の項目を作り、100件以上のレコードが入っている表があります。

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

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

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

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用紙で印刷したいと思います)

ちなみに画像は、エクセルファイルの置いてある下(サブフォルダ)にまとめて入れております。宜しくお願い致します。
投稿日時 - 2008-05-21 02:44:19

質問者が選んだベストアンサー

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

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

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

このコードで、セルC3以外は終了になりますよね?
残り2つのセルC15,C27は、何もしないでExit Subへ、ということです。


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

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

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

  ・・1つ目の処理・・・

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

  ・・2つ目の処理・・・

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

  ・・3つ目の処理・・・ 

End If

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

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



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

例えば、以下のように。。
 
'--------------------------------------------------------- 
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
'-----------------------------------------------------------

以上。
 
投稿日時 - 2008-05-21 12:05:04
この回答を支持する
(現在0人が支持しています)
お礼
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
=============================================================
投稿日時 - 2008-05-21 13:02:51

ベストアンサー以外の回答 (6)

回答No.2
再度の登場、onlyromです。

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

先の回答は、

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

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

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

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

= ではなく、<> のままですよね?

そこを修正して実行してください。
以上。
 
 
投稿日時 - 2008-05-21 14:17:45
この回答を支持する
(現在0人が支持しています)
お礼
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
=============================================================
投稿日時 - 2008-05-21 15:04:26
6件中 6~6件目を表示
この質問は役に立ちましたか?
0人が「このQ&Aが役に立った」と投票しています
もっと聞いてみる

関連するQ&A

この他の関連するQ&Aをキーワードで探す

同じカテゴリの人気Q&Aランキング

カテゴリ
Visual Basic
-PR-
-PR-
-PR-

特集

試写会に30組60名様をご招待!

お城、ボート、ツリーハウス、ユニークな物件満載!

親同士が気軽に情報交換できるコミュニティです。

同じカテゴリの人気Q&Aランキング

カテゴリ
Visual Basic
-PR-

ピックアップ

-PR-