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

質問

Ｅｘｃｅｌで棚割表を作っています。商品コードを打つとその商品の画像を自動で表示させたいのですが、雑誌を見ながらコードをアレンジしてほぼ完成したのですが、「プロシージャーが大きい」とエラーが出てマクロを実行出来ません。
画像は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

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

回答No.2

zap35 · ベストアンサー

＃０１です。先のマクロでは商品コードを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 '対応表のＢ列の値を格納
　　　　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

お礼

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

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

回答No.1

zap35

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

Ａ列　　　Ｂ列
A4　　　　画像１
A8　　　　画像２
A12　　　　画像３
　～中略～
U60　　　　画像９８

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

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

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