みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

VBAで画像を自動で切り替える方法

Excelで棚割表を作っています。商品コードを打つとその商品の画像を自動で表示させたいのですが、雑誌を見ながらコードをアレンジしてほぼ完成したのですが、「プロシージャーが大きい」とエラーが出てマクロを実行出来ません。
画像は100個程度あり、先に別のマクロで貼り付けてあります。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ファイル As String
If Intersect(Target, Range("A4")) Is Nothing Then
ActiveSheet.Shapes("画像").Delete
ファイル = "C:\保存場所\" & Range("A4").Value & ".jpg"
Range("B5").Select
ActiveSheet.Pictures.Insert(ファイル).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Top = ActiveCell.Top
Selection.ShapeRange.Left = ActiveCell.Left
Selection.ShapeRange.Height = 97
Selection.ShapeRange.Width = 52.5
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.IncrementLeft 1.5
Selection.ShapeRange.IncrementTop 1.5
Selection.Name = "画像"
End If

(中略)

Dim ファイル98 As String
If Intersect(Target, Range("U60")) Is Nothing Then Exit Sub
ActiveSheet.Shapes("画像98").Delete
ファイル98 = "C:\保存場所\" & Range("U60").Value & ".jpg"
Range("V61").Select
ActiveSheet.Pictures.Insert(ファイル98).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Top = ActiveCell.Top
Selection.ShapeRange.Left = ActiveCell.Left
Selection.ShapeRange.Height = 97
Selection.ShapeRange.Width = 52.5
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.IncrementLeft 1.5
Selection.ShapeRange.IncrementTop 1.5
Selection.Name = "画像98"
End Sub

省ける箇所や分割する方法などありましたら教えてください。

投稿日時 - 2007-09-20 18:09:14

QNo.3361854

すぐに回答ほしいです

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

#01です。先のマクロでは商品コードをDeleteしたときに画像が残ってしまいますね。以下に差し替えます。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ファイル As String
Dim nmPic As String
Dim res As Range
  Set res = Sheets("対応表").colomns(1).Find(Target.Address(False, False), _
    LookIn:=xlValues, lookat:=xlWhole)
  If res Is Nothing Then
    Exit Sub
  Else
    On Error Resume Next
    nmPic = res.Offset(0, 1).Value '対応表のB列の値を格納
    ActiveSheet.Shapes(nmPic).Delete
    If Target.Value <> "" Then
      ファイル = "C:\保存場所\" & Target.Value & ".jpg"
      Target.Offset(1, 1).Select
      ActiveSheet.Pictures.Insert(ファイル).Select
      Selection.Name = nmPic
      With Selection.ShapeRange
        .LockAspectRatio = msoTrue
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
        .Height = 97
        .Width = 52.5
        .Rotation = 0#
        .IncrementLeft 1.5
        .IncrementTop 1.5
      End With
    End If
  End If
End Sub

投稿日時 - 2007-09-20 19:41:17

お礼

早々の回答ありがとうございました。
さっそく対応表を作り、コードをコピーしましたが下記部分でエラーがでました。
  Set res = Sheets("対応表").colomns(1).Find(Target.Address(False, False), _
    LookIn:=xlValues, lookat:=xlWhole)
しかしながら、「.colomns(1)」を「.columns(1)」にする事で無事解決しました。

少ない説明で完璧な回答ありがとうございました。

投稿日時 - 2007-09-20 23:58:21

ANo.2

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

対応表というシートを作成し、A列に商品コードが入力されるセルアドレスを列記しておきます。B列はそのセルの右下セルに挿入する画像の名前です

A列   B列
A4    画像1
A8    画像2
A12    画像3
 ~中略~
U60    画像98

そうすれば以下のマクロだけで済むと思います。
商品コードが入力されたセルアドレスで対応表を検索し、合致するセルアドレスがあれば画像挿入の処理をするようにしています。
(テストはしていません。あしからず)

なお「On Error Resume Next」を追加したのは商品コードに対応する画像がシートにないときエラーとなるのを防止するためです。
オリジナルのロジックでは「最初から画像1~画像98が全てシート上にある」ときはエラーになりませんが、空いている表示欄に商品コードを入力すると削除しようとする画像がないのでエラーになりそうです。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ファイル As String
Dim res As Range
 If Target.Value = "" Then Exit Sub
 Set res = Sheets("対応表").colomns(1).Find(Target.Address(False, False), _
   LookIn:=xlValues, lookat:=xlWhole)
 If res Is Nothing Then
   Exit Sub
 Else
   On Error Resume Next
   ActiveSheet.Shapes(res.Offset(0, 1).Value).Delete
   ファイル = "C:\保存場所\" & Target.Value & ".jpg"
   Target.Offset(1, 1).Select
   ActiveSheet.Pictures.Insert(ファイル).Select
   Selection.Name = res.Offset(0, 1).Value
   With Selection.ShapeRange
     .LockAspectRatio = msoTrue
     .Top = ActiveCell.Top
     .Left = ActiveCell.Left
     .Height = 97
     .Width = 52.5
     .Rotation = 0#
     .IncrementLeft 1.5
     .IncrementTop 1.5
   End With
 End If
End Sub

投稿日時 - 2007-09-20 19:04:44

あなたにオススメの質問