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

クリップボードにある商品番号をカウントして入力するマクロです。
http://q.hatena.ne.jp/1215223897 ※回答2
一度解決した質問ですが仕様変更のため新たな質問として投稿いたします。
変更点は▼次の点です。

↓マクロ実行
↓次のメッセージを出す。
 「クリップボードの商品番号を追加しますか?」
  [はい]→データを追加する。
  [いいえ]→データを削減する

 [はい]をクリックした場合、既存の値に+1していく。
 [いいえ]をクリックした場合、既存の値に-1していく。

マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。

回答の条件
  • 1人5回まで
  • 登録:2008/07/16 22:31:40
  • 終了:2008/07/17 16:47:58

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692008/07/17 01:17:19

ポイント500pt
Sub MailAdd()
    Dim wsKan As Worksheet
    Dim SNumRetu As Integer      '商品番号列
    Dim cb As New DataObject
    Dim LastRow As Long
    Dim h
    Dim i As Long
    Dim j As Long
    Dim errorRow As Long
    Dim r As Range
    Dim zougen As Integer
    Dim ErrMes As String
    
    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
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    If Selection.Columns.Count <> 1 Or Selection.Row <> 1 Or Selection.Column = SNumRetu Then
        MsgBox ("店舗名を選択してください。")
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    cb.GetFromClipboard
    If cb.GetFormat(1) Then
        h = Split(cb.GetText, vbCrLf)
        LastRow = wsKan.Cells(Cells.Rows.Count, SNumRetu).End(xlUp).Row
        errorRow = LastRow + 3
        ErrMes = "エラー"
        If MsgBox("クリップボードの商品番号を追加しますか?" & vbNewLine & _
            "[はい] →データを追加する" & vbNewLine & _
            "[いいえ] →データを削減する", vbYesNo) = vbYes Then
            zougen = 1
        Else
            zougen = -1
        End If
        wsKan.Range(wsKan.Cells(LastRow + 1, Selection.Column), wsKan.Cells(65536, Selection.Column)).Clear
        For j = 0 To UBound(h)
            For i = 2 To LastRow
                If wsKan.Cells(i, SNumRetu).Value = h(j) Then
                    wsKan.Cells(i, Selection.Column).Value = wsKan.Cells(i, Selection.Column).Value + zougen
                    Exit For
                End If
                If i = LastRow Then
                    wsKan.Cells(LastRow + 2, Selection.Column).Value = "エラー"
                    wsKan.Cells(errorRow, Selection.Column).Value = h(j) & " " & j + 1 & "行目"
                    ErrMes = ErrMes & vbCrLf & h(j) & " " & j + 1 & "行目"
                    errorRow = errorRow + 1
                End If
            Next
        Next j
        
        If ErrMes <> "エラー" Then
            MsgBox ErrMes
            wsKan.Range(Cells(LastRow + 3, Selection.Column), Cells(errorRow - 1, Selection.Column)).Select
        End If
    End If
    
    Application.ScreenUpdating = True
End Sub

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692008/07/16 23:05:48

前回の仕様の

「新規のデータとしてカウントしますか?

  [はい]→新規のデータとしてカウント

  [いいえ]→データを追加する」

でいいえを選んだ後に今回のメッセージボックスが出るようにしました。

Sub MailAdd()
    Dim wsKan As Worksheet
    Dim SNumRetu As Integer      '商品番号列
    Dim cb As New DataObject
    Dim LastRow As Long
    Dim h
    Dim i As Long
    Dim j As Long
    Dim errorRow As Long
    Dim r As Range
    Dim zougen As Integer
    
    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
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    If Selection.Columns.Count <> 1 Or Selection.Row <> 1 Or Selection.Column = SNumRetu Then
        MsgBox ("店舗名を選択してください。")
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    cb.GetFromClipboard
    If cb.GetFormat(1) Then
        h = Split(cb.GetText, vbCrLf)
        LastRow = wsKan.Cells(Cells.Rows.Count, SNumRetu).End(xlUp).Row
        errorRow = LastRow + 3
        If MsgBox("新規のデータとしてカウントしますか?" & vbNewLine & _
            "[はい] →新規のデータとしてカウントする" & vbNewLine & _
            "[いいえ] →クリップボードの商品番号の追加", vbYesNo) = vbYes Then
            wsKan.Range(wsKan.Cells(2, Selection.Column), wsKan.Cells(65536, Selection.Column)).Clear
            zougen = 1
        Else
            If MsgBox("クリップボードの商品番号を追加しますか?" & vbNewLine & _
                "[はい] →データを追加する" & vbNewLine & _
                "[いいえ] →データを削減する", vbYesNo) = vbYes Then
                zougen = 1
            Else
                zougen = -1
            End If
            wsKan.Range(wsKan.Cells(LastRow + 1, Selection.Column), wsKan.Cells(65536, Selection.Column)).Clear
        End If
        For j = 0 To UBound(h)
            For i = 2 To LastRow
                If wsKan.Cells(i, SNumRetu).Value = h(j) Then
                    wsKan.Cells(i, Selection.Column).Value = wsKan.Cells(i, Selection.Column).Value + zougen
                    Exit For
                End If
                If i = LastRow Then
                    wsKan.Cells(LastRow + 2, Selection.Column).Value = "エラー"
                    wsKan.Cells(errorRow, Selection.Column).Value = h(j) & " " & j + 1 & "行目"
                    errorRow = errorRow + 1
                End If
            Next
        Next j
    End If
    
    Application.ScreenUpdating = True
End Sub
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/07/17 00:00:22

Sub MailAdd()
    Dim wsKan As Worksheet
    Dim SNumRetu As Integer      '商品番号列
    Dim cb As New DataObject
    Dim LastRow As Long
    Dim h
    Dim i As Long
    Dim j As Long
    Dim errorRow As Long
    Dim r As Range
    Dim zougen As Integer
    
    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
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    If Selection.Columns.Count <> 1 Or Selection.Row <> 1 Or Selection.Column = SNumRetu Then
        MsgBox ("店舗名を選択してください。")
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    cb.GetFromClipboard
    If cb.GetFormat(1) Then
        h = Split(cb.GetText, vbCrLf)
        LastRow = wsKan.Cells(Cells.Rows.Count, SNumRetu).End(xlUp).Row
        errorRow = LastRow + 3
        If MsgBox("クリップボードの商品番号を追加しますか?" & vbNewLine & _
            "[はい] →データを追加する" & vbNewLine & _
            "[いいえ] →データを削減する", vbYesNo) = vbYes Then
            zougen = 1
        Else
            zougen = -1
        End If
        wsKan.Range(wsKan.Cells(LastRow + 1, Selection.Column), wsKan.Cells(65536, Selection.Column)).Clear
        For j = 0 To UBound(h)
            For i = 2 To LastRow
                If wsKan.Cells(i, SNumRetu).Value = h(j) Then
                    wsKan.Cells(i, Selection.Column).Value = wsKan.Cells(i, Selection.Column).Value + zougen
                    Exit For
                End If
                If i = LastRow Then
                    wsKan.Cells(LastRow + 2, Selection.Column).Value = "エラー"
                    wsKan.Cells(errorRow, Selection.Column).Value = h(j) & " " & j + 1 & "行目"
                    errorRow = errorRow + 1
                End If
            Next
        Next j
    End If
    
    Application.ScreenUpdating = True
End Sub
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692008/07/17 01:17:19ここでベストアンサー

ポイント500pt
Sub MailAdd()
    Dim wsKan As Worksheet
    Dim SNumRetu As Integer      '商品番号列
    Dim cb As New DataObject
    Dim LastRow As Long
    Dim h
    Dim i As Long
    Dim j As Long
    Dim errorRow As Long
    Dim r As Range
    Dim zougen As Integer
    Dim ErrMes As String
    
    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
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    If Selection.Columns.Count <> 1 Or Selection.Row <> 1 Or Selection.Column = SNumRetu Then
        MsgBox ("店舗名を選択してください。")
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    cb.GetFromClipboard
    If cb.GetFormat(1) Then
        h = Split(cb.GetText, vbCrLf)
        LastRow = wsKan.Cells(Cells.Rows.Count, SNumRetu).End(xlUp).Row
        errorRow = LastRow + 3
        ErrMes = "エラー"
        If MsgBox("クリップボードの商品番号を追加しますか?" & vbNewLine & _
            "[はい] →データを追加する" & vbNewLine & _
            "[いいえ] →データを削減する", vbYesNo) = vbYes Then
            zougen = 1
        Else
            zougen = -1
        End If
        wsKan.Range(wsKan.Cells(LastRow + 1, Selection.Column), wsKan.Cells(65536, Selection.Column)).Clear
        For j = 0 To UBound(h)
            For i = 2 To LastRow
                If wsKan.Cells(i, SNumRetu).Value = h(j) Then
                    wsKan.Cells(i, Selection.Column).Value = wsKan.Cells(i, Selection.Column).Value + zougen
                    Exit For
                End If
                If i = LastRow Then
                    wsKan.Cells(LastRow + 2, Selection.Column).Value = "エラー"
                    wsKan.Cells(errorRow, Selection.Column).Value = h(j) & " " & j + 1 & "行目"
                    ErrMes = ErrMes & vbCrLf & h(j) & " " & j + 1 & "行目"
                    errorRow = errorRow + 1
                End If
            Next
        Next j
        
        If ErrMes <> "エラー" Then
            MsgBox ErrMes
            wsKan.Range(Cells(LastRow + 3, Selection.Column), Cells(errorRow - 1, Selection.Column)).Select
        End If
    End If
    
    Application.ScreenUpdating = True
End Sub
  • id:icta
    >SALINGERさん
    早々のご回答ありがとうございます。
    前回のものは棚卸し用だったのですが、今回のものは商品がA店→B店へ移動させるときのものです。
    これは頻繁に行われます。
    そのため前回のマクロの仕様に追加するのだと操作性に問題が出てきます。
    実際の運用では商品がA店→B店へ店間移動が行われるとき担当がメールで商品番号を改行して送ってきます。
    それから、A店の入庫を選択しマクロを実行。データを削減する」を選び、メールに記載された商品番号を削減します。
    次にB店の入庫を選択しマクロを実行。「データを追加する」を選び、メールに記載された商品番号を追加します。
    このように棚卸しとは関係がないため、記載した仕様でマクロを製作していただけると大変ありがたいです。
    よろしくお願いいたします。
  • id:SALINGER
    前回の仕様の
    「新規のデータとしてカウントしますか?
      [はい]→新規のデータとしてカウント
      [いいえ]→データを追加する」
    は無くして、新規にデータを追加するというのは無くするということでしょうか?
  • id:icta
    >SALINGERさん

    >新規にデータを追加するというのは無くするということでしょうか?

    はい、その通りです。
    前回は商品の棚卸用、今回は商品の店間移動用なのです。
    同じマクロですが別の用途に用います。
    よろしくお願いいたします。
  • id:icta
    >SALINGER さん
    早々の修正大変ありがとうございました。
    希望通りの動作を確認いたしました。
    実際に使ってみて、最後に1点だけ仕様を追加させていただいてもよろしいでしょうか?
    現状ではエラーが出たとき、最終行を確認しに行かないとエラーが出ているかどうかわかりません。
    そのためもしエラーがあった場合は▼以下のようにアラートウインドウを表示し、最終行+1行目にも同じものを書き込み、さらに「エラー」と表示されている最終行+1行目のセルを選択するように仕様を追加していただくことは可能でしょうか?

    エラー
    V07001BD 10行目
    S06001FF0 14行目

    なお、エラーがないときは▼次のアラートウインドウを表示します。

    正常に終了しました。

    現在の仕様のままだと、エラーに気がつかず作業を続けてしまう恐れがあります。
    この方法だとエラーがなければ「正常に終了」したことを伝え、もしエラーがある場合はアラートで明確にすることで修正しやすくなります。
    お手数ばかりおかけしますがご都合の許すときにお力添えいただければ幸いです。
  • id:icta
    >SALINGER さん
    早々の修正ありがとうございました。
    希望通りの動作を確認いたしました。
    これで在庫管理が大変楽になりました。
    次の機会もぜひよろしくお願いいたします。

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

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

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

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