エクセルデータ整理をVBAで行いたい

質問

シート１（表１）　　　　　　　　　　　　　　　 シート２（表２）
　A列　B列　C列　D列　　　　　　　　　　　 A列　B列　C列　D列
１名前　開始日　内容　終了日　　　　　　１名前　開始日　内容　終了日　
２鈴木　21年1月1日　AAA　○○○　　　 ２鈴木　○○○　○○○　21年11月1日　
３高橋　21年1月8日　BBB　○○○　　　 ３山田　○○○　○○○　21年11月1日　
４鈴木　21年1月20日　AAA　○○○　　 ４高橋　○○○　○○○　21年11月10日
５鈴木　21年2月10日　BBB　○○○　　　５高橋　○○○　○○○　22年9月30日
６山田　21年2月13日　AAA　○○○
７佐藤　21年3月3日　CCC　○○○
８高橋　21年11月24日　CCC　○○○
９高橋　21年11月24日　AAA　○○○

上記の表について下記の表になるように求めたいのですが、シート１のデータ数は約１７万行、シート２のデータ数は約６万行になります。
他の方の質問を参考に関数で求めようとしましたが、処理が非常に重く、入力した関数も成功しませんでした。
「VBAを使って作業をする」という結論に達しましたが、プログラムを組む知識がなく時間もないため皆さんの力をお借りしたいです。

条件
表２のB~C列は表１を参照し、表１のD列は表２を参照する
B列は、求めるセルのA列（名前）が一致する行を対象として、複数の行が該当する場合はその中でも終了日に最も近い開始日を求める
もし同じ数値があった場合は先に検索で該当した方の値を参照し、求めているセルの文字を赤字へ変更する（下記の表ではシート２のB5が赤字で表示される）
また、開始日＜終了日である
C列はB列で該当した開始日のある行のC列の値を求める
D列は各行のA~C列の値が一致した行のD列の値を求める

シート１（表１）　　　　　　　　　　　　　　　　　　　シート２（表２）
　A列　B列　C列　D列　　　　　　　　　　　　　　　 A列　B列　C列　D列
１名前　開始日　内容　終了日　　　　　　　　　 １名前　開始日　内容　終了日
２鈴木　21年1月1日　AAA　○○○　　　　　　 ２鈴木　21年2月10日　BBB　21年11月1日　
３高橋　21年1月8日　BBB　21年11月10日　　３山田　21年2月13日　AAA　21年11月1日　
４鈴木　21年1月20日　AAA　○○○　　　　　 ４高橋　21年1月8日　BBB　21年11月10日
５鈴木　21年2月10日　BBB　21年11月1日　　５高橋　21年11月24日　CCC　22年9月30日
６山田　21年2月13日　AAA　21年11月1日
７佐藤　21年3月3日　CCC　○○○
８高橋　21年11月24日　CCC　22年9月30日
９高橋　21年11月24日　AAA　○○○

説明がへたくそで申し訳ないですが、よろしくお願いします。

回答No.4

tom04 · ベストアンサー

こんばんは！
データ量が極端に多いみたいなので、かなりの時間を要すると思いますが・・・
一例です。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, k, M As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2") '←「Sheet2」の部分は実際のSheet名に！
Application.ScreenUpdating = False
For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Columns("A:D").AutoFilter field:=1, Criteria1:=ws.Cells(i, 1)
For k = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, 2), Cells(k, 2)), Cells(k, 2)) > 1 Then
Rows(k).Hidden = True
End If
Next k
For M = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Rows(M).Hidden = False And Cells(M, 2) <= ws.Cells(i, 4) Then
Range(Cells(M, 2), Cells(M, 3)).Copy Destination:=ws.Cells(i, 2)
ws.Cells(i, 4).Copy Destination:=Cells(M, 4)
End If
Next M
M = Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To M
If WorksheetFunction.CountIf(Range(Cells(k - 1, 4), Cells(M, 4)), Cells(k, 4)) > 1 Then
Cells(k, 4).ClearContents
End If
Next k
Next i
Worksheets("Sheet1").Select '←「Sheet1」の部分も実際のSheet名に！
Selection.AutoFilter
Application.ScreenUpdating = True
End Sub 'この行まで

※　検証していませんのでご希望通りの動きにならなかったら
ごめんなさいね。m（_ _）m

お礼

こんばんわ。
実際に動作を検証するには明日以降となってしまいます。
また、他の回答者様が言っているように条件が不足、具体性がないことがあげられました。
動作しなくても私の落ち度ですので気にしないでください。
回答を頂きありがとうございます。

回答No.3

mitarashi

もっと頭が悪いので、テストデータを作成して、Accessのクエリでやってみましたが、このデータは照合不可能な気がします。
あくまで乱数で作成したデータでの話ですが、1000個と500個のつき合わせで、25000個くらいの候補が挙げられ、収束できそうもありません。

>B列は、求めるセルのA列（名前）が一致する行を対象として、複数の行が該当する場合は
>その中でも終了日に最も近い開始日を求める

とありますが、実際にはある開始日と、内容の組み合わせに対して、複数の終了日の候補が挙げられ、どの終了日が正解かを定めるルールがありません。無理矢理開始日に一番近い終了日が該当とすれば定まりますが、他の「内容」との調整は取れませんので、複数の「内容」で同じ終了日を採用してしまう事が出てきてしまうので、正しいとは思えません。

手作業でのつき合わせができるとすると、種々の前提条件があると思うのですが、#1さんのおっしゃるとおり、それを明確にして、再度質問を立てられるのが良いと思います。

回答No.2

ShowMeHow

いろんなやり方があると思うけど、アクセスが私にとっては、一番手軽かな。

もうちょっと、問題を整理して、
いや、根本的に何をしたいかもう少し具体的に、
「その他データベース」で質問を立てていただいたほうが良いように思う。

たとえば、

表1には、誰が、何の本を、いつ借りたかが、借りた時間順に入っています。
同一日に複数の本を借りた場合は、複数連続で入っています。
表2には、誰が、直近に借りた本を返した日が入っています。　同一日に複数の本を返した場合でもデータは一つしかありません。
条件としては、一回に複数の本を借りることはできますが、借りた本を返さないで新たに本を借りることはできません。
このデータから、すべてのほんの所在状況を調べたいのですが可能ですか？

みたいにね。
オイラには、データの順番がどのように保障されているか良くわからないし、
あなたが最終的にほしいものが何なのかがはっきり理解しきれない。
（オイラ馬鹿でゴメン。）

お礼

>もうちょっと、問題を整理して、
いや、根本的に何をしたいかもう少し具体的に、
「その他データベース」で質問を立てていただいたほうが良いように思う。

次回投稿の際にはもう少しわかりやすいように努力してみます。「みなさんの視点からは抽象的すぎる」ということがわかっただけでも少し前進です。
回答ありがとうございました。

回答No.1

ShowMeHow

１７万行を１行ずつ６万行と付け合せるというのは、不可能とは言わないが、ちょっと非現実的。
アクセスでやるのはダメ？

エクセルで色付けについても、開いて目視するのが目的だろうけど、そんなことできるの？
対照リストをクエリで引っ張り出すほうが良いと思う。

お礼

すぐに回答を頂きありがとうございます。

＞アクセスでやるのはダメ？

エクセルで作業することが難しく、アクセスで作業するほうが良いのでしたら、アクセスでの作業も考慮します。

アクセスを使用したことがないので、アクセスについて下記HPを軽く閲覧しました。
http://www.sk-access.com/index.html

＞対照リストをクエリで引っ張り出すほうが良い

この操作を実際のデータで実行するには明日以降になりますが、手作業で付け合せを行うことが不要になりますか？