| |
▼どじょりん さん：
>１．sheet（削除一覧）の販売数欄に、台帳の在庫数が入力されている
> →台帳シートのA列の販売数を転記したい
ごめんなさい。アップされたレイアウトをよく見ていませんでした。
ところで、罫線ですが、元シートの罫線と同じスタイルということですか？
とりあえず、以下は元シートの罫線が、あっても無視して、新たに、適当なものをセットしています。
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
With .Range("A2").Resize(y, x) '★追加
.Value = Cells(2, wkCol + 2).Resize(y, x).Value '★変更
.Borders.LineStyle = xlThin '★追加
.Borders.Weight = xlContinuous '★追加
End With '★追加
.Range("D2").Resize(x).Value = .Range("A2").Resize(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
.Resize(.Rows.Count - 1, 2).Offset(1).ClearContents '★追加
End With
Cells(1, wkCol).CurrentRegion.Clear
Cells(1, wkCol + 2).CurrentRegion.Clear
Application.ScreenUpdating = True
MsgBox "処理が終わりました"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
