総ありがとう数 累計4,281万(2014年10月21日現在)

毎月4,000万人が利用!Q&Aでみんなで助け合い!

-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

その他の回答 (全6件)

  • 2008-05-21 23:37:54
  • 回答No.7
何度目の登場でしょうか、onlyromです。

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

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

ところがこれは、
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さんのような方に出逢えて本当に良かった
 です。

 明日の目覚めが最高の予感がします。
 では、おやすみなさい。
投稿日時 - 2008-05-22 00:09:32
通報する
  • 同意数0(0-0)
  • ありがとう数0
6件中 6~6件目を表示
  • 回答数7
  • 気になる数1
  • ありがとう数0
  • ありがとう
  • なるほど、役に立ったなど
    感じた思いを「ありがとう」で
    伝えてください

関連するQ&A

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

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

あなたの悩みをみんなに解決してもらいましょう

  • 質問する
  • 知りたいこと、悩んでいることを
    投稿してみましょう
-PR-
-PR-
-PR-

特集

専門医・味村先生からのアドバイスは必見です!

関連するQ&A

-PR-

ピックアップ

  • easy daisy部屋探し・家選びのヒントがいっぱい!

-PR-
ページ先頭へ