|
▼みどり さん:
> とりあえずは、(Sheet1)の方は AutoFilter方式でまとめて抽出できそう
> ですが、問題は (Sheet2) の転記先のシート構成ですね
AutoFilterで抽出した範囲を、(Sheet2)の最下行にコピーする例です。
つまり、N列に抽出日付の行があっても、上書きはされません。
ただ単に、まとめて抽出できることのテストコードです。
Sub Trial1()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim y2 As Long
Dim day1 As Double
Set WS1 = Workbooks("返却.xls").Worksheets("Sheet1") '◆実際の Workbook名 に変更
Set WS2 = Workbooks("転記先.xls").Worksheets("Sheet2")
WS2.Activate
With WS2.Cells(WS2.Rows.Count, "N").End(xlUp)
day1 = .Value
y2 = .Row + 1 '最終行+1
End With
'InputBoxで 抽出日付を入力する
day1 = Application.InputBox("抽出する日付を入力", _
WS2.Parent.Name, day1, Type:=1)
If day1 = 0 Then Exit Sub
With WS1.Range("A1").CurrentRegion
.AutoFilter
.AutoFilter 14, ">=" & day1 指定の日付より最近の行を抽出する
If WorksheetFunction.Subtotal(3, .Columns(14)) > 1 Then
'▼ とりあえず (sheet2)最下行へ コピーする
Intersect(.Cells, .Cells.Offset(1)).Copy WS2.Cells(y2, 1)
Else
MsgBox "転記元シートに " & day1 & " のレコードがありません"
End If
.AutoFilter
End With
End Sub
|
|