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

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

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

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

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


●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:はてな エクセル カウント クリック クリップボード
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●0ポイント

前回の仕様の

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

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

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

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

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

2 ● SALINGER
●0ポイント
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

3 ● SALINGER
●500ポイント ベストアンサー
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
関連質問


●質問をもっと探す●



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