-PR-
ykdream

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

ちなみに画像は、エクセルファイルの置いてある下(サブフォルダ)にまとめて入れております。宜しくお願い致します。
  • 回答数7
  • 気になる数1

Aみんなの回答(全7件)

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

  • 2008-05-21 12:05:04
  • 回答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
'-----------------------------------------------------------

以上。
 
お礼コメント
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
  • 同意数0(0-0)
  • ありがとう数0
-PR-
-PR-
  • 回答数7
  • 気になる数1
  • ありがとう数0
  • ありがとう
  • なるほど、役に立ったなど
    感じた思いを「ありがとう」で
    伝えてください
  • 質問する
  • 知りたいこと、悩んでいることを
    投稿してみましょう

関連するQ&A

-PR-
-PR-

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

別のキーワードで再検索する
-PR-
-PR-
-PR-

特集


『OKWave AWARD 2015』受賞者発表!

-PR-

ピックアップ

-PR-
ページ先頭へ