【マクロ】データベース更新毎に条件に合う行を転記

質問

初めて質問させていただきます。
エクセルVBAを勉強しはじめたところで、何とか自力で…と思っていたのですが、
締め切りが迫り、どうにもならずこちらにご助言を求めて質問させていただきました。

データ数5000ほどのデータベースがあります。
Sheet1に、

　　A　　B　　C　　　D　　・・・・BP
１　No.　ID　品名　日時　　　状況
２

となっており、BP列は0か1かのみ入力されています。
何もなければBPは0、何か問題があれば1となります。
Sheet1の内容は随時更新され、対象がすごく古いものでもBP=1になることがあります。

今回、Sheet2にBPが1のものだけを集めたデータベースを作成することになりました。
今現在BP＝１のものについては、オートフィルタで抽出しSheet2に貼り付けました。
しかし、今後もSheet1の内容が更新されていくことから、
新たにBP列が1となったデータの行の、A列からD列までのデータのみを
Sheet2の最終行に追加していく、しかもそれがSheet2のタブを開くたびに実行される
というデータベースの作成、そこからの資料作成を命じられました。

未熟な頭ながら、
オートフィルタでSheet1のBP列が1のものを抽出、貼り付け、重複するものを削除する…
と考えましたが、どうしてもうまくいきません。

大変恐縮ですが、どうかご教授ください。
よろしくお願いします！

回答No.1

tom04 · ベストアンサー

こんにちは！
BP列のデータが　0から1に　または　1から0に！　と変化するコトがあるのでしょうか？
もしそうであれば
＞Sheet2の最終行に追加していく、
というコトは難しいと思います。

そこでお望みの方法とは異なるかもしれませんが、
Sheet2を開くたびにSheet2のデータを一旦クリアにして、Sheet1のBP列が1のものだけを
新たにコピー＆ペーストする方法にしてみました。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
一旦↓のコードをコピー＆ペーストしてみてください。

Sub コピー() 'この行から
Dim i As Long, endRow As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
i = wS1.Cells(Rows.Count, "A").End(xlUp).Row
If i > 1 Then
wS2.Rows(2 & ":" & i).ClearContents
End If
With wS1
.Rows(1).AutoFilter , field:=68, Criteria1:=1
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(2, "A"), wS1.Cells(endRow, "D")).Copy wS2.Range("A2")
.AutoFilterMode = False
End With
End Sub 'この行まで

次にSheet2のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしSheet2をアクティブにしてみてください。

Private Sub Worksheet_Activate() 'この行から
Call コピー
End Sub 'この行まで

尚、Sheet2の1行目の項目は入力済みだとします。
これで質問の最初に書いてある
Sheet1をBP列が「1」のデータでフィルタをかけ、Sheet2に貼りつけています。

・・・別案・・・
※　Sheet1のBP列が　1から0に戻ることがないのであれば、Sheet1のシートモジュールで
BP列が1になったものだけをSheet2の最終行以降にコピー＆ペーストすることは可能です。
その場合、Sheet2がアクティブになろうがなるまいが関係ありません。

Sheet1のシートモジュールで↓のコードをコピー＆ペーストしてBP列データを1に変更してください。
そのデータだけがSheet2の最終行以降に表示されます。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
If Application.Intersect(Target, Range("BP:BP")) Is Nothing Or Target.Count <> 1 Then Exit Sub
If Target = 1 Then
Cells(Target.Row, "A").Resize(1, 4).Copy _
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End Sub 'この行まで

前者の方法か後者の方法かのどちらかのマクロで試してみてください。m（_ _）m

お礼

お礼が遅くなり失礼いたしました。抜けの多い質問に、時間を割いてご丁寧にご回答くださり、心から感謝申し上げます！BP列は1から0に戻ることはないので、別案をさっそく試させていただき、ばっっっちり作動しました！！これまでずっと悩んでいただけに、嬉しすぎてしばらく呆然としました…本当にありがとうございます！おかげさまで締め切りに間に合いそうです。重ね重ねありがとうございました！！

回答No.2

keithin

「新たにＢＰが１になった行」を，シート２の既存リストの『下に継ぎ足したい』のが今回のミッションだと理解します。（そうでないなら既出回答のように，毎回１で絞って全部転記するのが一番高速かつ簡単です。また「追記」ばかりでは，やはり既出回答でご指摘のように「１がゼロに戻った行」の扱いはどーするのかとかもありますね。）
あとはまぁ，「シート２を開いた時に自動実行」ですか。シート２を開いたままブックを保存して閉じてしまってた場合とかどうするんでしょう，などと心配ですが。

それと全体のデータ数は5000行との事ですが，ＢＰが１になる具体的なデータ数は何行ぐらいなんでしょうね。
5000の内の2000とか3000とか，かなりの数が１になるようならフィルタ関係を駆使した方が高速ですが，多くても数百程度でしたら逐一検査していってもさほどではないかもしれません。

ところで「新たにＢＰが１になった行」を検出したい時に，既にシート２にあるそれぞれの行がシート１の「どの行なのか」をどこで判別する（できる）のか，ご説明がヌケてます。
ふつーに考えてＡ列のＮｏは5000行分上から下までダブりのないユニークになっているとすると，ざっくりこんなマクロに出来ます。

手順：
シート２のシート名タブを右クリックしてコードの表示を選ぶ
現れたシートに下記をコピー貼り付ける

private sub Worksheet_Activate()
　dim h as range
　application.screenupdating = false
　with worksheets("Sheet1")
　.range("BP:BP").autofilter field:=1, criteria1:=1
　on error resume next
　for each h in .range("A2:A" & .range("A65536").end(xlup).row).specialcells(xlcelltypevisible)
　　if application.countif(range("A:A"), h.value) = 0 then
　　　range("A65536").end(xlup).offset(1).resize(1, 4).value = h.resize(1, 4).value
　　end if
　next
　.autofiltermode = false
　end with
　application.screenupdating = true
end sub

状況理解の間違い（たとえばユニークの判断）については，あなたの実際のエクセルに応じて適切にご自分で修正なさって下さい。

お礼

補足とほぼ同時のお礼となってしまい恐縮ですが…改めて感謝申し上げます。貴重なお時間を割いてコードを書いていただき、心より御礼申し上げます。抜けているポイントを教えていただいたことも大変ありがたく、今後もしもこちらにまたお世話になることがあれば、注意して記載するよう心がけようと思います。おかげさまで、資料作成もうまくいきそうです。重ね重ねありがとうございました！

補足

ご回答ありがとうございます！お示しいただいたマクロで、ばっちり願いどおりの結果を得ることができました！が、抜けの多い質問で申し訳ないので、いまさらですが補足させていただきます。
１．「新たにＢＰが１になった行」を，シート２の既存リストの『下に継ぎ足したい』のが今回のミッション…です。その通りです！
２．BP列の1が0に戻ることはありません。
３．BP列が1になるものは現時点では900程度ですが、今後さらに増える見込みです。データ数そのものも増えます。
４．5000行のA列のNoはだぶりのないユニークです。
拙い文章から核心をとらえていただき、本当にありがたいです。