-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
    -PR-
    -PR-
    • 回答数7
    • 気になる数1
    • ありがとう数0
    • ありがとう
    • なるほど、役に立ったなど
      感じた思いを「ありがとう」で
      伝えてください
    • 質問する
    • 知りたいこと、悩んでいることを
      投稿してみましょう
    こんな書き方もあるよ!この情報は知ってる?あなたの知識を教えて!
    このQ&Aにはまだコメントがありません。
    あなたの思ったこと、知っていることをここにコメントしてみましょう。

    関連するQ&A

    -PR-
    -PR-

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

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

    特集


    成功のポイントとは?M&Aで経営の不安を解決!

    -PR-

    ピックアップ

    -PR-
    ページ先頭へ