Excel VBA 集計方法

在庫状況にもとづいて、売上表の行を削除するマクロを組みたいと思います。（2つのシートに分かれています）
<共通条件>
お客様Noは一意です。
お客様No2以降は他のアカウントで別の品名が入っています。
<作業内容>
お客様No2以降も同様に売上表シートの行を削除します。
お客様ごとに同じ品名で在庫状況シートの本数まで、売上表シートの在庫状況列の「No」の行を削除します。在庫状況シートの本数を超えると売上表シートの在庫状況列の「Yes」の行を削除します。

上記の作業はマクロで可能でしょうか。

下記に表を記載します。

<在庫状況>シート
お客様Noお客様名　　　　　　品名本数在庫状況
1はなまる商事XYS Beta　5　Yes
2
3
4
5

<売上表>シート
お客様Noお客様名　　　　　　品名本数在庫状況
1はなまる商事XYS Beta1No
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1No
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1No
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1No
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1No
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1No
1はなまる商事XYS Beta1Yes

<マクロ実行後の結果>
お客様Noお客様名品名本数在庫状況
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1Yes
1はなまる商事XYS Beta1No

※表がずれていますが、品名はアルファベットです。

No.6 ベストアンサー 回答者： ka_na_de 回答日時： 2010/03/22 07:37

おはようございます。

期待通りに動いて良かったです。
しかし、質問に提示されたデータで動いても
実際の運用場面ではさまざまに予期せぬ動きをするかもしれません。
いろいろと条件を変えて試し、不具合が無いか確認してください。

前回のコードでは、
１）<売上表>シート の本数は全て１とは限らず、
　　Ｙｅｓの行の数量を合計して判断するようにしています。
２）<売上表>シートのＹｅｓの数がそもそも、
　　<在庫状況>シート の数量より少ない場合には
　　<在庫状況>シート の数量に一致するように、
　　データを加えています。　この処理が不要なら教えてください。

さて、本題の同じお客様で複数の異なる製品がある場合ですが、
前回のコードを応用して、Ｃ列でもフィルターで絞り込むように
修正しました。

Sub test4()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myLastRow1 As Long
　　Dim myLastRow2 As Long
　　Dim myCustomer As Long
　　Dim myStocks As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim flg As Boolean
　　Dim myRange As Range
　　Dim mySum As Long
　　Dim myGoods As String

　　Application.ScreenUpdating = False

　　Set Ws1 = Worksheets("在庫状況")
　　Set Ws2 = Worksheets("売上表")

　　myLastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row

　　With Ws2
　　　　.Range("A1").CurrentRegion.Sort _
　　　　　　Key1:=.Range("A1"), Order1:=xlAscending, _
　　　　　　Key2:=.Range("C1"), Order2:=xlAscending, _
　　　　　　Key3:=.Range("E1"), Order3:=xlDescending, _
　　　　　　Header:=xlGuess
　　　　For i = 2 To myLastRow1
　　　　　　myCustomer = Ws1.Cells(i, "A").Value
　　　　　　myGoods = Ws1.Cells(i, "C").Value
　　　　　　myStocks = Ws1.Cells(i, "D").Value
　　　　　　k = 0
　　　　　　mySum = 0
　　　　　　flg = False
　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　With .Range("A1").CurrentRegion
　　　　　　　　.AutoFilter Field:=1, Criteria1:=myCustomer
　　　　　　　　.AutoFilter Field:=3, Criteria1:=myGoods
　　　　　　　　.AutoFilter Field:=5, Criteria1:="No"
　　　　　　End With
　　　　　　Set myRange = .Range("A1:A" & myLastRow2).SpecialCells(xlCellTypeVisible)
　　　　　　Set myRange = Intersect(.Range("A2:A" & myLastRow2), myRange)
　　　　　　If Not myRange Is Nothing Then myRange.EntireRow.Delete

　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row
　　　　　　With .Range("A1").CurrentRegion
　　　　　　　　.AutoFilter Field:=1, Criteria1:=myCustomer
　　　　　　　　.AutoFilter Field:=3, Criteria1:=myGoods
　　　　　　　　.AutoFilter Field:=5, Criteria1:="Yes"
　　　　　　End With
　　　　　　Set myRange = .Range("D1:D" & myLastRow2).SpecialCells(xlCellTypeVisible)
　　　　　　Set myRange = Intersect(.Range("D2:D" & myLastRow2), myRange)
　　　　　　If Not myRange Is Nothing Then
　　　　　　　　mySum = Application.WorksheetFunction.Subtotal(9, myRange)
　　　　　　End If

　　　　　　If myStocks < mySum Then
　　　　　　　　With myRange
　　　　　　　　　　For j = 1 To .Cells.Count
　　　　　　　　　　　　k = .Cells(j).Value + k
　　　　　　　　　　　　If k > myStocks Then
　　　　　　　　　　　　　　If flg = False Then
　　　　　　　　　　　　　　　　.Cells(j).Value = .Cells(j).Value - k + myStocks
　　　　　　　　　　　　　　　　.Cells(j).EntireRow.Copy
　　　　　　　　　　　　　　　　Ws2.Rows(myLastRow2 + 1).Insert Shift:=xlDown
　　　　　　　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　　　　　　　Ws2.Cells(myLastRow2 + 1, "D").Value = k - myStocks
　　　　　　　　　　　　　　　　Ws2.Cells(myLastRow2 + 1, "E").Value = "No"
　　　　　　　　　　　　　　　　myLastRow2 = myLastRow2 + 1
　　　　　　　　　　　　　　　　flg = True
　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　.Cells(j).Offset(, 1).Value = "No"
　　　　　　　　　　　　 End If
　　　　　　　　　　　　ElseIf k = myStocks Then
　　　　　　　　　　　　　　flg = True
　　　　　　　　　　　　End If
　　　　　　　　　　Next j
　　　　　　　　End With
　　　　　　ElseIf mySum < myStocks Then
　　　　　　　　Ws1.Rows(i).EntireRow.Copy
　　　　　　　　.Rows(myLastRow2 + 1).Insert Shift:=xlDown
　　　　　　　　Application.CutCopyMode = False
　　　　　　　　.Cells(myLastRow2 + 1, "D").Value = myStocks - mySum
　　　　　　　　myLastRow2 = myLastRow2 + 1
　　　　　　End If
　　　　Next i
　　　　.AutoFilterMode = False
　　　　.Range("A1").CurrentRegion.Sort _
　　　　　　Key1:=.Range("A1"), Order1:=xlAscending, _
　　　　　　Key2:=.Range("C1"), Order2:=xlAscending, _
　　　　　　Key3:=.Range("E1"), Order3:=xlDescending, _
　　　　　　Header:=xlGuess
　　End With

　　Application.ScreenUpdating = True

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange = Nothing
End Sub



'「世界でいちばん簡単なExcel VBAのe本」を購入されたのですね。
'私は他の本で勉強したあとに、この本に出会いましたが、
'最初にこれを読めば良かったなあと心から思っています。
' For Each...Next 文の解説が無いことだけが不満です。

この回答へのお礼

ご回答ありがとうございます。実際の運用データを使用して試していきます。また、ご提供頂いたマクロを1文1文確認して理解していきます。

お礼日時：2010/03/22 13:28

No.5 回答者： ka_na_de 回答日時： 2010/03/20 17:37

＃２です。

作り直しました。問題無いか試してみてください。
問題がなければ、教えてください。
追加補足質問の（２）に移ります。

Sub test3()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myLastRow1 As Long
　　Dim myLastRow2 As Long
　　Dim myCustomer As Long
　　Dim myStocks As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim flg As Boolean
　　Dim myRange As Range
　　Dim mySum As Long

　　Application.ScreenUpdating = False

　　Set Ws1 = Worksheets("在庫状況")
　　Set Ws2 = Worksheets("売上表")
　　
　　myLastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row
　　
　　With Ws2
　　　　For i = 2 To myLastRow1
　　　　　　myCustomer = Ws1.Cells(i, "A").Value
　　　　　　myStocks = Ws1.Cells(i, "D").Value
　　　　　　k = 0
　　　　　　mySum = 0
　　　　　　flg = False
　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　With .Range("A1").CurrentRegion
　　　　　　　　.AutoFilter Field:=1, Criteria1:=myCustomer
　　　　　　　　.AutoFilter Field:=5, Criteria1:="No"
　　　　　　End With
　　　　　　Set myRange = .Range("A1:A" & myLastRow2).SpecialCells(xlCellTypeVisible)
　　　　　　Set myRange = Intersect(.Range("A2:A" & myLastRow2), myRange)
　　　　　　If Not myRange Is Nothing Then myRange.EntireRow.Delete
　　　　　　
　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row
　　　　　　With .Range("A1").CurrentRegion
　　　　　　　　.AutoFilter Field:=1, Criteria1:=myCustomer
　　　　　　　　.AutoFilter Field:=5, Criteria1:="Yes"
　　　　　　End With
　　　　　　Set myRange = .Range("A1:A" & myLastRow2).SpecialCells(xlCellTypeVisible)
　　　　　　Set myRange = Intersect(.Range("A2:A" & myLastRow2), myRange)
　　　　　　If Not myRange Is Nothing Then
　　　　　　　　mySum = Application.WorksheetFunction.Subtotal(9, myRange.Offset(, 3))
　　　　　　End If

　　　　　　If myStocks < mySum Then
　　　　　　　　With myRange.Offset(, 3)
　　　　　　　　　　For j = 1 To .Cells.Count
　　　　　　　　　　 k = .Cells(j).Value + k
　　　　　　　　　　　　If k > myStocks Then
　　　　　　　　　　　　　　If flg = False Then
　　　　　　　　　　　　　　　　.Cells(j).Value = .Cells(j).Value - k + myStocks
　　　　　　　　　　　　　　　　.Cells(j).EntireRow.Copy
　　　　　　　　　　　　　　　　Ws2.Rows(myLastRow2 + 1).Insert Shift:=xlDown
　　　　　　　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　　　　　　　Ws2.Cells(myLastRow2 + 1, "D").Value = k - myStocks
　　　　　　　　　　　　　　　　Ws2.Cells(myLastRow2 + 1, "E").Value = "No"
　　　　　　　　　　　　　　　　myLastRow2 = myLastRow2 + 1
　　　　　　　　　　　　　　　　flg = True
　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　.Cells(j).Offset(, 1).Value = "No"
　　　　　　　　　　　　 End If
　　　　　　　　　　　　ElseIf k = myStocks Then
　　　　　　　　　　　　　　flg = True
　　　　　　　　　　　　End If
　　　　　　　　　　Next j
　　　　　　　　End With
　　　　　　ElseIf mySum < myStocks Then
　　　　　　　　Ws1.Rows(i).EntireRow.Copy
　　　　　　　　.Rows(myLastRow2 + 1).Insert Shift:=xlDown
　　　　　　　　Application.CutCopyMode = False
　　　　　　　　.Cells(myLastRow2 + 1, "D").Value = myStocks - mySum
　　　　　　　　myLastRow2 = myLastRow2 + 1
　　　　　　End If
　　　　Next i
　　　　.AutoFilterMode = False
　　　　.Range("A1").CurrentRegion.Sort _
　　　　　　Key1:=.Range("A1"), Order1:=xlAscending, _
　　　　　　Key2:=.Range("E1"), Order2:=xlDescending, _
　　　　　　Header:=xlGuess
　　End With

　　Application.ScreenUpdating = True

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange = Nothing
End Sub

この回答への補足

修正ありがとうございます。
内容を確認しました。
問題ございません。
引き続きよろしくお願いいたします。

別件ですが、先日ご紹介頂きました「世界でいちばん簡単なExcel VBAのe本」を購入しました。代入やカウンタ変数の箇所はとてもわかりやすく理解できました。基本文法は何度も繰り返し勉強して理解を深めたいと思います。

補足日時：2010/03/21 23:04

No.4 回答者： ka_na_de 回答日時： 2010/03/20 01:05

２点確認させてください。

１）<売上表>シート の本数は全て１なのですか？
　　<在庫状況>シート の本数が５の場合、
　　<売上表>シートのＹｅｓを５行残せばよいのですか？
　　それとも、Ｙｅｓの行の数量を合計して５になるように残すのですか？

２） <売上表>シート のＮｏの行は最初に全て削除して
　　　その後、Ｙｅｓの数を<在庫状況>シート の数量に
　　　あわせて、余分が出ればＮｏに書き換える
　　　ということですか？
　　
　　また、
　　<売上表>シートのＹｅｓの数がそもそも、
　　<在庫状況>シート の数量より少ない場合などは無いのでしょうか？

尚、回答に対する返信は明日以降になると思います。

この回答への補足

1)<売上表>シートの本数は全て1ではございません。
2であったり10であったりいろいろです。
<売上表>シートのＹｅｓを5行残してください。

2)<売上表>シートのＹｅｓの数が、<在庫状況>シート の数量より少ない場合はございます。

補足日時：2010/03/21 22:49

No.3 回答者： ka_na_de 回答日時： 2010/03/20 00:03

こんばんは。

以下の条件で作ったつもりです。

＞お客様ごとに同じ品名で在庫状況シートの本数まで、売上表シートの在庫状況列の「No」の行を削除します。在庫状況シートの本数を超えると売上表シートの在庫状況列の「Yes」の行を削除します。

ご提示の<売上表>シート の例では、
Yesが６行、Ｎｏが６行あります。
ご提示の<在庫状況>シートの例では、
本数が５
となっていますので、
まず、Ｎｏを５行削除します。
Ｎｏが５行削除できたので、コレで終了。

もし、
ご提示の<在庫状況>シートの例で、
本数が７
であれば、
まず、Ｎｏを６行削除します。
削除するＮｏの行が無くなったので、Ｙｅｓの行を１行削除。


おそらく、質問文に対する私の解釈が間違っているのだと思います。
もう少し、具体的にどういう動きをすれば良いのか補足説明をお願いします。

尚、追加質問の（２）はこれが解決してから考えます。

この回答への補足

説明が足りない部分があり、大変申し訳ございません。
在庫数：5本の場合
<売上表>シートの在庫状況列(E列）のYesを5個残すイメージです。
Noを6行削除します。
Yesが1行多いので、これは<売上表>シートの在庫状況列（E列）を
のYesをNoにします。

※<売上表>シートの在庫状況列(E列）のNoとYesは、どちらかの行を
削除するため、12行あれば6行残ります。
ただし上記のように、<在庫状況>シートの本数列(D列）を<売上表>シートの在庫状況列（E列）Yesの最大数としていますので、YesをNoに変更する作業が必要となります。

よろしくお願いいたします。

補足日時：2010/03/20 00:34

No.2 回答者： ka_na_de 回答日時： 2010/03/18 22:50

こんばんは。

２つのシートのどちらにも、見出し行がある前提で作りました。

Sub test1()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myLastRow1 As Long
　　Dim myLastRow2 As Long
　　Dim myCustomer As Long
　　Dim myStocks As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long

　　Application.ScreenUpdating = False

　　Set Ws1 = Worksheets("在庫状況")
　　Set Ws2 = Worksheets("売上表")
　　
　　myLastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row
　　
　　For i = 2 To myLastRow1
　　　　myCustomer = Ws1.Cells(i, "A").Value
　　　　myStocks = Ws1.Cells(i, "D").Value
　　　　k = 0
　　　　With Ws2
　　　　　　.Range("A1").CurrentRegion.Sort _
　　　　　　　　　　　　Key1:=.Range("A1"), Order1:=xlAscending, _
　　　　　　　　　　　　Key2:=.Range("E1"), Order2:=xlDescending, _
　　　　　　　　　　　　Header:=xlGuess
　　　　　　For j = myLastRow2 To 2 Step -1
　　　　　　　　If .Cells(j, "A").Value = myCustomer Then
　　　　　　　　　　k = .Cells(j, "D").Value + k
　　　　　　　　　　If k <= myStocks Then
　　　　　　　　　　　　.Rows(j).Delete
　　　　　　　　　　Else
　　　　　　　　　　　　.Cells(j, "D").Value = k - myStocks
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next j
　　　　End With
　　Next i
　　
　　Application.ScreenUpdating = True

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
End Sub

この回答への補足

テストサンプルいつもありがとうございます。勉強になります。
2点確認させてください。
(1)マクロ実行後の結果ですが、在庫状況Yesが6個とNoが1個になっています。在庫状況Yesを5個、Noを1個にしたいのですが可能でしょうか。
(2)同じお客様で複数の異なる製品がございます。その場合も同様に製品ごとに処理したいと思います。在庫表シートと売上表シートのいずれもC列に条件を付ける必要があると思います。こちらもサンプルがありましたらお教えください。

補足日時：2010/03/19 23:34

No.1 回答者： nattocurry 回答日時： 2010/03/18 04:47

在庫状況の列を基準に、Noが上になるようにソートして、在庫状況シートの本数分だけ上から行を削除すればよいです。

順番を変えたくないのなら、ソートする前に、ID列を設けてIDを順にふっておいてから、上記作業をし、作業が終わったら、ID順でソートしなおせばよいです。

これらの作業を、「マクロの記録」しましょう。

その後の微調整で解らないところがあったら、改めてここで質問しましょう。

この回答へのお礼

アドバイスありがとうございました。マクロの記録を使用して進めていきます。

お礼日時：2010/03/19 22:45