Excelの見積書でJANコードを入れたら画像名と一致する図を呼び出したい

エクセルで見積書を作成しているのですが、商品のJANコードを入力するとその商品の画像が表示されるようなマクロを組みたいと思っております。

１枚のシートで５品の商品が作成できる見積書になります。

１品の場合はできたのですが、、、初心者の為お力をお借りをできればと思います。

１品目
◎JANコード入力セル　C３０
◎画像挿入箇所のセル　B１８
２品目
◎JANコード入力セル　H３０
◎画像挿入箇所のセル　G１８
３品目
◎JANコード入力セル　M３０
◎画像挿入箇所のセル　L１８
４品目
◎JANコード入力セル　R３０
◎画像挿入箇所のセル　Q１８
５品目
◎JANコード入力セル　W３０
◎画像挿入箇所のセル　V１８

Private Sub Worksheet_Change(ByVal Target As Range)
Const trgR As String = "C30" '地図通し番号を入力するセル
Const insR As String = "B18" '挿入画像の左上のセル
Const path As String = "C:\Users\〇〇〇\Desktop\イージーシェルフ V7\" 'ファイルの格納フォルダ
Const pic As String = ".jpg" '「.(半角)」＋ファイルの拡張子"
Dim shp As Shape
Dim buf As String
If Target.Address(0, 0) = trgR Then
For Each shp In ActiveSheet.Shapes '既に表示されている画像を削除する処理
If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
shp.BottomRightCell)) Is Nothing Then
shp.Delete
End If
Next
Range(insR).Select
buf = Dir(path & Target.Value & pic)
If buf <> "" Then '入力したファイル名があるかチェック
ActiveSheet.Pictures.Insert (path & Target.Value & pic)
Else
MsgBox "指定したファイルがありません"
End If
End If
Target.Offset(1, 0).Select

質問者からの補足コメント

• 見積書はこんな感じのものを使用しております。

  
    補足日時：2018/01/08 22:34

No.9 ベストアンサー 回答者： GooUserラック 回答日時： 2018/01/09 08:14

No.8 のお礼について

No.7 のコードは画像の高さ・幅のうち割合が大きい方を最大値に合わせるように縦横比を保ったまま拡大・縮小します。（環境が違うのでテストしていませんので、変な動作をした場合はご連絡ください）

ちなみに｢138.6｣｢156｣などの最大値は実際に貼り付けた画像のポイント数です。
計算で求めるときは、「ポイント数に≒28.34×センチ数」になりますので、それぞれ｢138.866｣｢155.87｣の方が良いかもしれませんが、実際の印刷ではプリンターの単位はインチ単位で、あまり細かく指定しても適当に直されてしまいますのであまり細かく指定する必要はありません。

この回答へのお礼

ありがとうございます。
今、Excelにマクロを貼付けて起動確認してみました。

大変効率が上がりました。
本当にありがとうございます！

まだまだわからないことが多々ありますが今後ともよろしくお願い致します。

お礼日時：2018/01/09 08:34

No.8 回答者： GooUserラック 回答日時： 2018/01/09 03:53

ちなみに、画像が小さいときは拡大しない方が良いですか？

この回答へのお礼

遅くまでありがとうござます！

画像が小さい場合は拡大できるのでしょうか？
固定のサイズに合わせれるとベストです。

マクロはかなり便利なのが今回で大変勉強になりました。
一から勉強をしてみようと思いました。

お礼日時：2018/01/09 07:03

No.7 回答者： GooUserラック 回答日時： 2018/01/09 03:47

No.6 の修正です。

縦横比が近いものの時の処理が間違っていました。以下と入れ替えて下さい。
--------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Const path As String = "C:\Users\〇〇〇\Desktop\イージーシェルフ V7\" 'ファイルの格納フォルダ
Const pic As String = ".jpg" '「.(半角)」＋ファイルの拡張子"
Const HMax As Variant = 138.6 '高さ(4.9cm)
Const WMax As Variant = 156 '幅(5.5cm)
Dim HSize As Variant
Dim WSize As Variant
Dim ARatio As Variant
Dim shp As Shape
Dim buf As String
Dim insR As String '挿入画像の左上のセル
Select Case Target.Address(0, 0)
Case "C30"
insR = "B18"
Case "H30"
insR = "G18"
Case "M30"
insR = "L18"
Case "R30"
insR = "Q18"
Case "W30"
insR = "V18"
End Select
If insR <> "" Then
For Each shp In ActiveSheet.Shapes '既に表示されている画像を削除する処理
If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
shp.BottomRightCell)) Is Nothing Then
shp.Delete
End If
Next
Range(insR).Select
buf = Dir(path & Target.Value & pic)
If buf <> "" Then '入力したファイル名があるかチェック
ActiveSheet.Pictures.Insert(path & Target.Value & pic).Select
ARatio = WMax / HMax
HSize = Selection.ShapeRange.Height
WSize = Selection.ShapeRange.Width
Selection.ShapeRange.LockAspectRatio = msoTrue
If HSize * ARatio > WSize Then
Selection.ShapeRange.Height = HMax
Else
Selection.ShapeRange.Width = WMax
End If
End If
End If
If Target.Row = 30 Or Target.Row = 31 Then
Target.Offset(1, 0).Select
End If
End Sub
--------------------------------------------------------------------------------

No.6 回答者： GooUserラック 回答日時： 2018/01/09 02:00

こんな感じでは？

--------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Const path As String = "C:\Users\〇〇〇\Desktop\イージーシェルフ V7\" 'ファイルの格納フォルダ
Const pic As String = ".jpg" '「.(半角)」＋ファイルの拡張子"
Const HMax As Variant = 138.6 '高さ(4.9cm)
Const WMax As Variant = 156 '幅(5.5cm)
Dim HSize As Variant
Dim WSize As Variant
Dim ARatio As Variant
Dim shp As Shape
Dim buf As String
Dim insR As String '挿入画像の左上のセル
Select Case Target.Address(0, 0)
Case "C30"
insR = "B18"
Case "H30"
insR = "G18"
Case "M30"
insR = "L18"
Case "R30"
insR = "Q18"
Case "W30"
insR = "V18"
End Select
If insR <> "" Then
For Each shp In ActiveSheet.Shapes '既に表示されている画像を削除する処理
If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
shp.BottomRightCell)) Is Nothing Then
shp.Delete
End If
Next
Range(insR).Select
buf = Dir(path & Target.Value & pic)
If buf <> "" Then '入力したファイル名があるかチェック
ActiveSheet.Pictures.Insert(path & Target.Value & pic).Select
ARatio = HMax / WMax
HSize = Selection.ShapeRange.Height
WSize = Selection.ShapeRange.Width
If HSize < WSize * ARatio Then
Selection.ShapeRange.Height = HMax
Else
Selection.ShapeRange.Width = WMax
End If
End If
End If
If Target.Row = 30 Or Target.Row = 31 Then
Target.Offset(1, 0).Select
End If
End Sub
--------------------------------------------------------------------------------

No.5 回答者： GooUserラック 回答日時： 2018/01/09 00:24

まず選択セルの部分の変更ですが

「Target.Offset(1, 0).Select」を以下の３行にしてみてください。
--------------------------------------------------------------------------------
If Target.Row = 30 Or Target.Row = 31 Then
Target.Offset(1, 0).Select
End If
--------------------------------------------------------------------------------

No.4 回答者： GooUserラック 回答日時： 2018/01/08 23:51

No.3 について

なぜ、確認したかというと「本体価格」や「入数」の所に入力したとき、移るセルが違うのでは？と思ったからです。

お礼について
画像サイズについてももちろん可能ですが、縦・横の最大サイズが多分決まっているのでそれに合わせて自動で拡大・縮小するのが一番だと思うのですが、それぞれの最大サイズはいくつでしょうか？

この回答へのお礼

ご返信ありがとうございます。
おっしゃるとおりですね。

JANコードを入力すると数式で、定番納価と特売納価の部分以外は数式で商品マスターより引用されるように
数式を入れております。

JANコード入力後→定番納価　が正しいと思います。

また画像のサイズですが、高さ４．９cm　幅　５．５ｃｍのエクセル上での設定です。
画像は伸びるようであれば、はじめにマクロで挿入できた画像を枠に合わせて調整しようと思います。

お礼日時：2018/01/08 23:59

No.3 回答者： GooUserラック 回答日時： 2018/01/08 23:33

No.2 の追補

このコードだと何か入力すると必ず１行下に下がるようになっていますが、元のコードには「End Sub」が無かったので、その辺の処理もこの後に有るのでしょうか？

この回答へのお礼

処理はこの後ありません。
テストしてみました！

ありがとうござます。
完璧な状態で動作確認取れました。

ちなみに相談なのですが、画像サイズが大きいもの（縦・横のサイズ）ですが
マクロ上で呼び出したときに、縦の大きさを指定すると横も自動的に調整可能でしょうか？

縦の変更により横も自動的に調整がなる縮尺機能を追加できればさらにと思いました。

お礼日時：2018/01/08 23:36

No.2 回答者： GooUserラック 回答日時： 2018/01/08 23:23

こんな感じではどうでしょうか？

--------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Const path As String = "C:\Users\〇〇〇\Desktop\イージーシェルフ V7\" 'ファイルの格納フォルダ
Const pic As String = ".jpg" '「.(半角)」＋ファイルの拡張子"
Dim shp As Shape
Dim buf As String
Dim insR As String '挿入画像の左上のセル
Select Case Target.Address(0, 0)
Case "C30"
insR = "B18"
Case "H30"
insR = "G18"
Case "M30"
insR = "L18"
Case "R30"
insR = "Q18"
Case "W30"
insR = "V18"
End Select
If insR <> "" Then
For Each shp In ActiveSheet.Shapes '既に表示されている画像を削除する処理
If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
shp.BottomRightCell)) Is Nothing Then
shp.Delete
End If
Next
Range(insR).Select
buf = Dir(path & Target.Value & pic)
If buf <> "" Then '入力したファイル名があるかチェック
ActiveSheet.Pictures.Insert (path & Target.Value & pic)
End If
End If
Target.Offset(1, 0).Select
End Sub
--------------------------------------------------------------------------------
※ こちらではテストしていませんが大して変更していないのでエラーは出ないと思いますがおかしかったら言ってください。

No.1 回答者： GooUserラック 回答日時： 2018/01/08 22:35

画像ファイルが無いときの処理ですが、いちいちメッセージの表示は必要なのでしょうか？

貼り付けられていなければ無かったと考えた方が手っ取り早いと思うのですが…

この回答へのお礼

ありがとうございます。
メッセージの表示はなくても大丈夫です。

私も言われてみればそう思いました。
お力になっていただけますでしょうか？

お礼日時：2018/01/08 22:38