1213122992 エクセルのマクロの質問です。次のマクロははてなで回答者の方々に作成していただいたマクロです。

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

回答の条件
  • 1人5回まで
  • 登録:2008/06/11 03:36:35
  • 終了:2008/06/11 22:05:12

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/11 11:09:48

ポイント500pt

私のパソコンの環境は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
  • id:icta
    > SALINGERさん

    早々のご回答ありがとうございました。
    ほぼ期待どおりの動作で大変うれしいです。
    最後に1点だけ確認したいのですが、仕様(画像)にある”「商品管理.xls」が開いていない場合、マクロ実行後に「商品管理.xls」が開くがマクロが停止する。開いた後に停止せず処理を継続する。”を実行するのは難しいでしょうか?
    現状ではマクロ実行時に「商品管理.xls」が開いていないと「商品管理.xls」が自動的に開きますが、開いたばかりの「商品管理.xls」のページ内でマクロが停止します。そこでもう一度「顧客管理.xls」の「来店記録」シートに戻って再度マクロを実行しています。
    以前作成していただいた▼以下のマクロでは、「顧客管理.xls」が開いていない場合、自動的に開き、マクロの処理を継続します。
    http://q.hatena.ne.jp/1211716499
    このようにシームレスな動作名になれば助かります。
    事前に「商品管理.xls」を開いておけばいいだけのことですので、もし特にコードが長くなるようでしたらご回答は不要です。
    ほぼ期待どおりの結果に大変満足しておりますので明日には質問を締め切らせていただきます。
    ありがとうございました。
  • id:SALINGER
    商品管理を開いたときにそちらがアクティブになって、処理が止まったみたいです。
    商品管理を開いた後に、すぐ来店記録をアクティブにすればいいですね。
    3分の1くらいのところにある。
    On Error GoTo 0
    の後に
    raiWS.Activate
    を挿入してください。
  • id:icta
    > SALINGERさん

    早々のご回答ありがとうございました。
    完全に期待通りの動作を確認できました。
    運用してみると思いがけない使い方をするスタッフがいて驚かされます。
    今後も仕様の変更などがあるかと思いますがまたお知恵とお力をお借りできれば幸いです。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません