| |
▼どじょりん さん：
こんにちは
アップされたコードを踏まえようかとも思いましたが、全くの別方式で。
以下を前提にしています。
１．コマンドボタンは、台帳シートに配置された｢ActiveXボタン｣（コントロールツールボックスのボタン）
２．で、CommandButton1_Click は台帳シートのシートモジュールに書かれている。
３．台帳シートの１行目は、完全に空白セル。（ボタンのみ配置されていて、値が入っていない）
また、勝手に、処理後、D列の在庫数を引落し、その結果、在庫が０になったものを消しています。
（実際には、削除は行わず、在庫があるものだけで上書きしています）
Private Sub CommandButton1_Click()
Dim wkCol As Long
Dim x As Long
Dim y As Long
If WorksheetFunction.Count(Columns("A")) = 0 Then
MsgBox "削除すべきデータがありません"
Exit Sub
End If
Application.ScreenUpdating = False
'まず空白以外を抽出
wkCol = Range("A2").CurrentRegion.Columns.Count + 2 '作業列番号
Cells(1, wkCol).Value = Range("A2").Value '販売数タイトル
Cells(2, wkCol).Value = "<>" '抽出条件 空白以外
Range("A2").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Cells(1, wkCol).Resize(2), CopyToRange:=Cells(1, wkCol + 2), Unique:=False
With Cells(1, wkCol + 2).CurrentRegion
y = .Rows.Count - 1 '抽出データ行数
x = .Columns.Count '一覧列数
End With
With Worksheets("削除一覧")
.Rows(2).Resize(y).Insert
.Range("A2").Resize(y, x).Value = Cells(2, wkCol + 2).Resize(y, x).Value
.Range("A2").Resize(y).Value = Date
End With
'在庫引落
y = Range("A" & Rows.Count).End(xlUp).Row
Range("A3:A" & y).Copy
Range("D3").PasteSpecial Paste:=xlPasteAll, Operation:=xlSubtract, _
SkipBlanks:=False, Transpose:=False
Cells(1, wkCol + 2).CurrentRegion.Clear
Cells(1, wkCol).Value = Range("D2").Value '在庫数タイトル
Cells(2, wkCol).Value = ">0" '抽出条件 在庫 0
Range("A2").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Cells(1, wkCol).Resize(2), CopyToRange:=Cells(1, wkCol + 2), Unique:=False
'リスト置換え
With Range("A2").CurrentRegion
.Value = Cells(1, wkCol + 2).Resize(.Rows.Count, .Columns.Count).Value
End With
Cells(1, wkCol).CurrentRegion.Clear
Cells(1, wkCol + 2).CurrentRegion.Clear
Application.ScreenUpdating = True
MsgBox "処理が終わりました"
End Sub
|
|
UO3
- 12/2/28(火) 14:49 -
