人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルのマクロの質問です。今度バーコードで商品を管理することになりました。現在、商品番号、商品名等の商品情報を「商品管理.xls」というファイルに記載しております。バーコードを付けやすくするため商品番号に対応する商品画像を「商品管理.xls」に載せたいと思います。
http://q.hatena.ne.jp/1154052414 で紹介されていた方法で、商品画像を「商品管理.xls」に載せることはできました。
これにさらに次の機能を追加するにはどうしたらよいでしょうか?
・"商品番号"列のセルを複数選択してマクロを実行、選択した商品番号に対応する商品画像を表示、選択したセルの行の高さを"128"にする。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

1215172879
●拡大する

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:xls エクセル コメント コード セル
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●0ポイント
tmp = ActiveWorkbook.Path & "\商品画像\" & Mid(ActiveCell.Value, 1, Len(ActiveCell.Value) - 3) & "m.jpg"

ここの名前の後ろの3文字を削除して、"m.jpg"をつけるというのがよくわからないけど、

そのまま使って作ってみました。

勝手に前のマクロの仕様も少し引き継いでいます。


Option Explicit

Sub PicInsert()
 Dim wsKan As Worksheet
 Dim SNameRetu As Integer  '商品名列
 Dim SGazouRetu As Integer  '商品番号列
 Dim tmp As String
 Dim r As Range
 
 If ThisWorkbook.Name <> "商品管理.xls" Or ActiveSheet.Name <> "商品管理" Then
 MsgBox "操作が誤っています。商品画像を挿入する場合は商品管理ファイルの" & _
 "商品管理シートの商品名列でマクロを実行してください。"
 Exit Sub
 End If
 
 Set wsKan = Worksheets("商品管理")
 
  'タイトル列がない場合の処理
 Set r = wsKan.Rows(1).Find(what:="商品名", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品名の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNameRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="商品画像", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品画像の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SGazouRetu = r.Column
 End If
 
  '商品名のセル選択しているか
 If Selection.Columns.Count <> 1 Or Selection.Column <> SNameRetu Then
 MsgBox ("商品名を選択してください。")
 Exit Sub
 End If
 
 For Each r In Selection
 If Len(r.Value) > 3 Then
 tmp = ActiveWorkbook.Path & "\商品画像\" & Mid(r.Value, 1, Len(r.Value) - 3) & "m.jpg"
 If Dir(tmp) <> "" Then
 wsKan.Cells(r.Row, SGazouRetu).Select
 wsKan.Pictures.Insert(tmp).Select
 wsKan.Rows(r.Row).RowHeight = 128
 Else
 wsKan.Cells(r.Row, SGazouRetu).Value = "NO IMAGE"
 End If
 End If
 Next
End Sub

2 ● SALINGER
●1500ポイント
Option Explicit

Sub PicInsert()
 Dim wsKan As Worksheet
 Dim SNumRetu As Integer  '商品番号列
 Dim SGazouRetu As Integer  '商品画像列
 Dim tmp As String
 Dim r As Range
 Dim s As Shape
 Dim LastRow As Long
 Dim i As Long
 
 If ThisWorkbook.Name <> "商品管理.xls" Or ActiveSheet.Name <> "商品管理" Then
 MsgBox "操作が誤っています。商品画像を挿入する場合は商品管理ファイルの" & _
 "商品管理シートの商品番号列でマクロを実行してください。"
 Exit Sub
 End If
 
 Set wsKan = Worksheets("商品管理")
 
  'タイトル列がない場合の処理
 Set r = wsKan.Rows(1).Find(what:="商品番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品番号の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SNumRetu = r.Column
 End If
 
 Set r = wsKan.Rows(1).Find(what:="商品画像", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "商品画像の列名は存在しません。商品管理シートを確認してください。"
 Exit Sub
 Else
 SGazouRetu = r.Column
 End If
 
 Application.ScreenUpdating = False
 
  '画像の挿入か削除の選択
 If MsgBox("商品画像を挿入しますか?" & vbNewLine & _
 "[はい] →選択したセルの商品画像を挿入する。" & vbNewLine & _
 "[いいえ] →商品画像を一括削除する。", vbYesNo) = vbYes Then
  '商品番号のセル選択しているか
 If TypeName(Selection) <> "Range" Then Exit Sub
 If Selection.Columns.Count <> 1 Or Selection.Column <> SNumRetu Then
 MsgBox ("商品番号を選択してください。")
 Exit Sub
 End If
 
 For Each r In Selection
 If Len(r.Value) > 3 Then
 tmp = ActiveWorkbook.Path & "\商品画像\" & Mid(r.Value, 1, Len(r.Value) - 3) & "m.jpg"
 If Dir(tmp) <> "" Then
 wsKan.Cells(r.Row, SGazouRetu).Select
 wsKan.Pictures.Insert(tmp).Select
 wsKan.Rows(r.Row).RowHeight = 128
 Else
  '画像が無かった場合NO IMAGEと表示
 wsKan.Cells(r.Row, SGazouRetu).Value = "NO IMAGE"
 End If
 End If
 Next
 Else
  '画像だけ削除
 For Each s In wsKan.Shapes
 If s.Type = msoPicture Then
 s.Delete
 End If
 Next
  '行の高さを調整
 LastRow = wsKan.Cells(Cells.Rows.Count, SNumRetu).End(xlUp).Row
 For i = 2 To LastRow
 wsKan.Cells(i, SGazouRetu).Value = ""
 wsKan.Rows(i).RowHeight = 12
 Next i
 End If
 
 Application.ScreenUpdating = True
End Sub
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ