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

エクセルのマクロの質問です。現在、商品番号、商品名、各店舗の入庫数など商品情報を「商品管理.xls」の"商品管理"シートに入力しています。
クリップボードにある商品番号をこのシートと照らし合わせ、クリップボードにどの商品がいくつあるのかカウントして"商品管理"シートに記録するマクロを作りたいと考えています。
概要は画像を参照ください。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

1215223897
●拡大する

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

▽最新の回答へ

1 ● SALINGER
●0ポイント

メールの本文をコピーして、商品番号以外の一列目を選択して実行することでその下にカウントを入れるマクロです。

新宿など店舗名はわからないので、操作するほうで正しい店舗を選択する必要があります。

もう一つ注意することは、クリップボードに文字列が入っているかどうかで処理をするのですが、

セルをコピーした後マクロを実行してしまった場合でも文字列と認識されるので意図しない動作をする場合があります。

Option Explicit

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
 
 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
 wsKan.Range(Cells(LastRow + 1, Selection.Column), 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 + 1
 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
●1500ポイント ベストアンサー
Option Explicit

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
 
 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
 Else
 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 + 1
 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 ● Mook
●50ポイント

勝手ながら、仕様を何点か変更してみました。

SALINGER さんが忠実な回答をされていると思いますので、そちらがご希望に沿うようでしたらそちらを採用ください。

ポイントは不要です(いつも過分にいただいていることもありますので)。


コメントしましたが、OutLook をお使いの場合、「発注フォルダ」を作成しそこに該当メールを置いて実行してみてください。

そのフォルダ内のメールを順番に処理します。

機能を追加することも可能ですが、処理後「登録済みフォルダ」などへ移動する運用がよいと思います。


また、「商品管理」シートを選んでいない場合、エラーメッセージを出すとの仕様でしたが、

「商品管理」シートをアクティブにして処理をするようにしていますので、その点も変更しています。

Const dstFolder = "発注フォルダ"
Const errorTitle = "エラー"
Const MainSheet = "商品管理"

Sub registOrder()
 Dim olAPP As Object
 Set olAPP = CreateObject("Outlook.Application")
 
 Dim olNameSPC As Object
 Set olNameSPC = olAPP.GetNamespace("MAPI")

 Workbooks("商品管理.xls").Worksheets(MainSheet).Activate

'--- 発注フォルダを探してその中のメールを順番に処理
 Dim objItem As Object
 Dim intCounter As Integer
 Dim objFolder As Object
 For Each objFolder In olNameSPC.Folders(1).Folders
 If objFolder.Name = dstFolder Then
 For Each objItem In objFolder.items
 intCounter = intCounter + 1
 loadOrder objItem.Subject, objItem.body
 Next objItem
 Exit For
 End If
 Next
End Sub

'------------------------------------------------
' タイトル(支店名)と商品リストを登録
'------------------------------------------------
Sub loadOrder(title, body)
 With Worksheets(MainSheet)
 Dim items
 items = Split(body, vbNewLine)
 
 Dim ret As Range
 Set ret = .Rows(1).Find(what:=title, lookat:=xlWhole)
 If ret Is Nothing Then
 MsgBox "該当する支店名「" & title & "」がありません。"
 Exit Sub
 End If
 
 Dim bCol As Long
 bCol = ret.Column
 
 Dim i As Long
 Dim errorNum As Long
 For i = LBound(items) To UBound(items)
 If Len(items(i)) > 0 Then
 Set ret = .Columns(1).Find(what:=Trim(items(i)), lookat:=xlWhole)
 If ret Is Nothing Then
 errorNum = addError(bCol, items(i), i - LBound(items) + 1)
 Else
 .Cells(ret.Row, bCol).Value = .Cells(ret.Row, bCol).Value + 1
 End If
 End If
 Next
 If errorNum > 0 Then
 MsgBox "存在しない商品番号が" & errorNum & "件ありました。" & vbNewLine & "シートの最終行を確認してください。"
 End If
 End With
End Sub

'------------------------------------------------
' 該当商品がない場合、エラーを記録
'------------------------------------------------
Function addError(bCol As Long, item, iRow)
 With Worksheets(MainSheet)
 Dim ret As Range
 Dim eReg As Range
 Set ret = .Columns(bCol).Find(what:=errorTitle, lookat:=xlWhole)
 If ret Is Nothing Then
 Set ret = .Cells(Rows.Count, bCol).End(xlUp).Offset(2, 0)
 ret.Value = errorTitle
 Set eReg = ret.Offset(1, 0)
 Else
 Set eReg = ret.End(xlDown).Offset(1, 0)
 End If
 eReg.Value = item & " " & iRow & "行目"
 addError = eReg.Row - ret.Row
 End With
End Function

一点、今回の処理はセルの数値を直接加算していくものですが、処理が失敗した場合、処理漏れがあった場合、複数回処理した場合、

数値を修正・復元することは管理上困難です。

読み込んだデータをすべて個別に登録管理し、そこから集計するか、少なくともその記録と合わせて管理する方が好ましい

かと思います。

関連質問


●質問をもっと探す●



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