Excel VBAで在庫状況に基づいて売上表の行を削除する方法

質問

• Excel VBAを使用して、在庫状況に基づいて売上表の行を削除する方法について教えてください。
• マクロを使って、在庫状況に応じて売上表の行を削除する方法を教えてください。
• 在庫状況を基にして、Excel VBAで売上表の特定の行を削除する方法を知りたいです。

回答No.6

ka_na_de · ベストアンサー

おはようございます。

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

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

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

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文確認して理解していきます。