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

エクセルのマクロの質問です。次のマクロははてなで回答者の方々に作成していただいたマクロです。
商品番号から商品名を呼び出すマクロです。
http://q.hatena.ne.jp/1210860623
↓改良
http://q.hatena.ne.jp/1212804845
一度解決した質問ですが仕様の変更のため新たな質問として投稿いたします。
変更点は画像をご覧ください。仕様変更を行うのは下段の改良後のマクロです。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。

1213122992
●拡大する

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:はてな エクセル コード ポイント マクロ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● SALINGER
●500ポイント ベストアンサー

私のパソコンの環境はCPU、メモリと高速な環境で少ないデータでテストしてるので、

処理時間をあまり考えないでコードしていました。

カンマは、半角・全角・「、」に対応しておきました。

Sub MacroSyouhinTenki()
 Application.ScreenUpdating = False
 
  '管理ブックのパスを環境に合わせてください
 Const myPath As String = "C:\管理"
  '商品管理のブック名
 Const wbName As String = "商品管理.xls"
  '商品管理のワークシート名
 Const wsName As String = "商品管理"
 
 Dim i As Integer
 Dim j As Long
 Dim k As Integer
 Dim l As Integer
 Dim sName As String
 Dim sNum As String
 Dim retu() As Integer
 Dim f As Boolean
 Dim rr As Integer
 Dim r As Range
 Dim sList As String
 Dim dstWS As Worksheet  '商品管理シート
 Dim raiWS As Worksheet  '来店記録シート
 Dim syouhinNum As Integer  '商品管理の商品番号列
 Dim syouhinName As Integer  '商品管理の商品名列
 Dim r1 As Range
 Dim r2 As Range
 Dim h() As String
 Dim s As Variant
 
 Set raiWS = ActiveSheet
 
  '商品管理を開く
 On Error GoTo err_Trp
 If bookCheck(myPath & "\" & wbName) Then
 Set dstWS = Workbooks(wbName).Worksheets(wsName)
 Else
 Set dstWS = Workbooks.Open(myPath & "\" & wbName).Worksheets(wsName)
 End If
 On Error GoTo 0
 
 Set r1 = dstWS.Rows(1).Find(what:="商品番号", lookat:=xlWhole)
 If r1 Is Nothing Then
 MsgBox "商品管理に商品番号の列がありません。"
 Exit Sub
 End If
 syouhinNum = r1.Column
 
 Set r2 = dstWS.Rows(1).Find(what:="商品名", lookat:=xlWhole)
 If r1 Is Nothing Then
 MsgBox "商品管理に商品名の列がありません。"
 Exit Sub
 End If
 syouhinName = r2.Column
 
 With raiWS
  '列に挿入されたることを考えて商品番号が何列目かを調べます
 i = 1
 While .Cells(1, i).Value <> "商品番号"
 i = i + 1
 Wend
 
 ReDim retu(0) As Integer
 For Each r In Selection
 rr = r.Row
 f = False
 For l = 0 To UBound(retu)
 If retu(l) = rr Then
 f = True
 Exit For
 End If
 Next l
 If f = False Then
 sName = ""
 sNum = ""
 k = i
 While .Cells(rr, k).Value <> ""
 
 h = Split(Replace(Replace(.Cells(rr, k).Value, "、", ","), ",", ","), ",")
 
 For Each s In h
 j = 2
 While dstWS.Cells(j, syouhinNum).Value <> s And _
 dstWS.Cells(j, syouhinNum).Value <> ""
 j = j + 1
 Wend
 
 sList = dstWS.Cells(j, syouhinName).Value
 If sList = "" Then
 sList = "存在しない商品番号"
 End If
 
 If sName = "" Then
 sName = sList
 Else
 sName = sName & "," & sList
 End If
 If sNum = "" Then
 sNum = s
 Else
 sNum = sNum & "," & s
 End If
 Next
 .Cells(rr, k).Value = ""
 k = k + 1
 Wend
 
 .Cells(rr, i - 1).Value = sName
 .Cells(rr, i).Value = sNum
 
 ReDim Preserve retu(UBound(retu) + 1) As Integer
 retu(UBound(retu)) = rr
 End If
 Next r
 End With
 
 Application.ScreenUpdating = True
 Exit Sub
 
err_Trp:
 Select Case Err.Number
 Case 1004
 MsgBox "商品管理をオープンできません。パスを確認してください。"
 Case 9
 MsgBox "商品管理の正しいブック名とシート名を指定してください。"
 Case Else
 MsgBox "商品管理をオープンすることができませんでした。"
 End Select
 Application.ScreenUpdating = True
End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
 Dim f As Boolean
 Dim myBook As Workbook
 For Each myBook In Workbooks
 If myBook.Path & "\" & myBook.Name = myPath Then
 f = True
 Exit For
 End If
 Next
 bookCheck = f
End Function
関連質問


●質問をもっと探す●



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