Excel VBAでデータを自動処理したい（２）

質問

Excelで大量のデータ処理をしなくてはならないのですが、以下の処理をExcel VBAで自動処理できないでしょうか？どなたかお知恵をお貸しください。
別シートに参照リストと未完成リストがあります。参照リストのA列のデータの並びと未完成リストのA列の並びを同じくして、未完成リストを完成させます。参照リストのA列の並びはこんな風です。1 2 3 3 5 6 7 8 8 10 ・・・（データは昇順ですが必ずしも連番ではなく、同じデータが並ぶこともあります。）　そして未完成リストの方は、1 2 3 4 5 7 8 10 ・・・といった風です。未完成リストのA列は1 2 3 3 4 5 7 8 8 10・・・という風にしたいのです。つまり参照リストにあっても、未完成リストにないデータは無視します。（上の例では、6です。）参照リストになくて、未完成リストにあるデータはそのまま残します。（上の例では、4です。）両方に共通のデータで参照リストのようにデータが重複しているときは、未完成リストの方に重複している分だけ行を挿入し、上のデータをコピーします。（上の例では、3と8です。）この処理を例えば、それぞれのA列を比較し、お互い共通していないデータ行をそれぞれのリスト上で不可視にし、そのあと、参照リストのA列のデータを参考に重複してるデータを見つけたら、未完成リストの方に重複している分だけ自動に行を挿入し、上のデータをコピーして、参照リストと未完成リストの共通のデータを同じならびにしたいのです。（このあと、参照リストのB,C,Dのデータを未完成リストにコピーするので、未完成リストにしかないA列のデータは、不可視にしておいて、B,C,Dのデータをコピーするときに行がずれないようにしたいのです。）
以上(1)、(2)の処理を自動にさせるためのVBAが分かる方がいらっしゃいましたら、是非ご教授お願いいたします。

回答No.5

nishi6 · ベストアンサー

充実した昼休みでした！

***追加A*** とコメントがある行はSheet4作成用です。
***追加B*** はSheet1で無視したデータの先頭セルを赤にします。（記入されていた、未完成リストNo.1上でこれらのデータに赤い色をつける・・・は参照リストを対象にしました）
***追加AB*** は両方に必要な行です。コメント行もありますが。
前回は未完成リストより大きい番号の参照リストデータは無視していましたが、処理対象とするためWhile、Wendを追加しています。
試して見て下さい。うまくいくといいですね。では。

Public Sub KanseiList()
Dim rg1, rg2, rg3 As Range '基準とするセル
Dim rg4 As Range '基準とするセル ***追加A***
Dim cot1 As Long '参照リストカウンタ
Dim cot2 As Long '未完成リストカウンタ
Dim cot3 As Long '完成リストカウンタ
Dim cot4 As Long '無視リストカウンタ ***追加A***
'
Const copyCol = 3 'コピーする列数(0から)
Dim cl As Integer '列カウンタ
'
Set rg1 = Worksheets("Sheet1").Range("A1")
Set rg2 = Worksheets("Sheet2").Range("A1")
Set rg3 = Worksheets("Sheet3").Range("A1")
Set rg4 = Worksheets("Sheet4").Range("A1") '***追加A***
Worksheets("Sheet3").UsedRange.Clear
Worksheets("Sheet4").UsedRange.Clear '***追加A***
'
'前回赤にしたセルを元に戻しておく(再処理への備え) '***追加B***
Worksheets("Sheet1").Range("A:A").Interior.ColorIndex = xlNone '***追加B***
'
With rg2
While .Offset(cot2, 0) <> ""
Select Case True
Case .Offset(cot2, 0) = rg1.Offset(cot1, 0)
'参照リストと未完成リストが一致
While .Offset(cot2, 0) = rg1.Offset(cot1, 0)
For cl = 0 To copyCol
'参照リストのAからD列をコピーする
rg3.Offset(cot3, cl) = rg1.Offset(cot1, cl)
Next
cot1 = cot1 + 1 '参照リストを更に調べる
cot3 = cot3 + 1
Wend
cot2 = cot2 + 1
Case rg1.Offset(cot1, 0) <> "" And .Offset(cot2, 0) < rg1.Offset(cot1, 0)
'未完成リストしかない(参照リストはある)
While rg2.Offset(cot2, 0) <> "" And .Offset(cot2, 0) < rg1.Offset(cot1, 0)
rg3.Offset(cot3, 0) = .Offset(cot2, 0)
cot2 = cot2 + 1 '未完成リストを更に調べる
cot3 = cot3 + 1
Wend
Case rg1.Offset(cot1, 0) = ""
'未完成リストしかない(参照リストがない)
rg3.Offset(cot3, 0) = .Offset(cot2, 0)
cot2 = cot2 + 1
cot3 = cot3 + 1
Case .Offset(cot2, 0) > rg1.Offset(cot1, 0)
'参照リストしかない
For cl = 0 To copyCol '***追加A***
rg4.Offset(cot4, cl) = rg1.Offset(cot1, cl) '***追加A***
Next '***追加A***
'色(赤色=3)をつける ***追加B***
rg1.Offset(cot1, 0).Interior.ColorIndex = 3 '***追加B***
cot4 = cot4 + 1 '***追加A***
cot1 = cot1 + 1
End Select
Wend
'参照リストにまだデータがある場合(基準とした未完成リストはデータがなくなった) ***追加AB***
While rg1.Offset(cot1, 0) <> "" '***追加AB***
For cl = 0 To copyCol '***追加A***
rg4.Offset(cot4, cl) = rg1.Offset(cot1, cl) '***追加A***
Next '***追加A***
'色(赤色=3)をつける ***追加B***
rg1.Offset(cot1, 0).Interior.ColorIndex = 3 '***追加B***
cot4 = cot4 + 1 '***追加AB***
cot1 = cot1 + 1 '***追加AB***
Wend '***追加AB***
End With
End Sub

お礼

nishi6さん、お昼休みの貴重なお時間を割いてまで、私どものわがままな申し出を聞いてくださり、何とお礼を申し上げればよいか分かりません。しかも2通りのプログラムをこんな短時間で作られてしまうなんて、社員一同驚愕しております。先にご回答くださったapril21さんもnishi6さんも何て素晴らしい技術をお持ちなんでしょう!!うらやましい限りでございます。このプログラムはまさに鬼に金棒です。本当に何から何までお世話になり、ありがとうございました。今回のことで私は真剣にプログラミングに取り組んでみようと強く思うようになりました。nishi6さんもapril21さんも私に新たな分野に挑戦するきっかけをくださいました。このことは私の人生にとって大きな意味を持つように思います。昼間nishi6さんのご回答を会社で読んだのですが、午後私は出かける予定があり、プログラムの実行が出来ませんでしたので、明日早速やってみようと思っております。とってもわくわくしております。本当にどうもありがとうございました。