Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

24737 / 76732

←次へ　｜　前へ→


	【57342】Re:抽出データをコピーし、貼り付けたいのですが・・

kanabun - 08/8/9(土) 19:12 -


	引用なし

	パスワード

▼みどりさん：

> とりあえずは、（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

6 hits

▼

【57327】抽出データをコピーし、貼り付けたいのですが・・ みどり 08/8/7(木) 23:58