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さんのご回答を会社で読んだのですが、午後私は出かける予定があり、プログラムの実行が出来ませんでしたので、明日早速やってみようと思っております。とってもわくわくしております。本当にどうもありがとうございました。

回答No.4

april21

sheet1のデータ、sheet2のデータ、sheet3のデータＡ列をそのまま使いたいのであれば下記のように書き換えてsheet4のＡ列に

=Sheet2!A1&"は未完成リストで"&COUNTIF(参照リスト,Sheet2!A1)&"件"&IF(COUNTIF(参照リスト,Sheet2!A1)=0,"シート2のみ","")

適当に変更してください。

回答No.3

april21

＞どのデータが無視されたものなのか後で分かるように

nishi6さんが忙しい間、下記数式でどのデータが無視されたものなのか調べてみては？

A列に参照リスト（データの範囲に参照リストと名前を定義します）
B列に未完成リスト（データの範囲に未完成リストと名前を定義します）
名前の定義の方法は「Excel VBAでデータを自動処理したい」に書いたので省きます。

■C1など適当なセルに↓の数式をコピーして貼り付けます。
貼り付けたものをコピーしてB列と同数のセルを選択して貼り付けます。

=B1&"は未完成リストで　"&COUNTIF(参照リスト,B1)&"件"&IF(COUNTIF(参照リスト,B1)=0,"Bデータのみ","")

■↑と同じく貼り付け
=A1&"は参照リストで　"&COUNTIF(未完成リスト,A1)&"件"&IF(COUNTIF(未完成リスト,A1)=0,"Aデータのみ","")

↑の数式で「4は未完成リストで0件Bデータのみ」　「6は参照リストで0件Aデータのみ」というように表示されるばすです。

◎ここからコピーして直貼りするとセルの高さが変になるのでメモ帳とかに貼り付けてコピーしなおしてセルに。
nishi6さん(。・_・。)ノがんばってねぇ～♪
慣れなれしいすぎ　バキッ！☆／（x_x)ごめ

お礼

april21さん、前回の質問に引き続きこちらの方もご回答くださりありがとうございます。数式だけでもこのようなことが出来るのですね。ご参考にさせていただきます。

回答No.2

nishi6

過分なお言葉恐縮しています。皆さんのお役に立ててうれしく思います。追記の件ですが了解しました。何行か追加すれば可能と思います。ただ、明日（25日）はサボリの時間がもてそうにないので１日程度お待ちください。では皆さんがんばって下さい。

お礼

nishi6さん、本当ですか？お忙しい中、お引き受けくださるとは！！前回のご回答に対するお礼を申し上げたことで、かえってnishi6さんに、余計な負担をおかけしてしまったようで恐縮しております。申し訳ありません。本当にお時間があるとき、気が向いたときで結構なのですよ。どうぞ無理をしないでくださいませ。

回答No.1

nishi6

何度か読んでやりたいこと（かな？）を作ってみました。主旨を汲んでいなければお許しを。
参照リスト、未完成リスト、未完成リストの完成版が必要とお思いますので、それぞれSheet1,Sheet2,Sheet3に
対応して作りました。また、未完成リストの完成後フィルタを使ったりしてのコピー作業があるようなのでそれも組み込んでみました。コピーしたい列数-1をcopyColにセットします。私見ですがVBAで対応する場合は手作業を極力排除した方がいいと思います。質問ではA列の最後がどのようになっているか想像できませんでしたので、参照リスト個数＞＝＜未完成リスト個数の３パターンに対応しています。（つもりです）

Public Sub KanseiList()
Dim rg1, rg2, rg3 As Range '基準とするセル
Dim cot1 As Long '参照リストカウンタ
Dim cot2 As Long '未完成リストカウンタ
Dim cot3 As Long '完成リストカウンタ
'
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") '未完成リスト完成版
Worksheets("Sheet3").UsedRange.Clear
'
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)
'参照リストしかない
cot1 = cot1 + 1
End Select
Wend
End With
End Sub

お礼

nishi6さん、早々のご回答ありがとうございます。早速やってみました。大成功でした。会社の皆で大喝采でした。本当にありがとうございます。今日は会社の仲間たちの顔が皆晴れやかで社内がパッと明るくなりました。ところでnishi6さん、ご相談のですが、こんなすばらしいプログラムを提供していただいて、恐縮なのですが、このプログラムに以下の機能を追加することは可能でしょうか？参照リスト（sheet1のデータ）にあって、未完成リストNo.1（sheet2のデータ）に無いデータは、未完成リスト完成版（sheet3）には反映されず無視されますよね。実はこの無視されたデータは後で、別の未完成リストNo.2と照し合せる必要があるのです。そこで、どのデータが無視されたものなのか後で分かるように,未完成リストNo.1上でこれらのデータに赤い色をつけるとか、またこのデータだけをsheet4に抽出する等（どちらか1つでいいのですが・・・）出来ますでしょうか？これが出来ると本当に鬼に金棒なのですが・・・。でもこのプログラムでも私たちにとっては本当に大助かりでございますので、もしnishi6さんが気が向いたら、ご返答いただければ・・・と図々しくもお願いした次第です。でもどうか気になさらないでくださいませ。ご迷惑でしたら、どうぞ無視されて結構です。まずは社員一同お礼心よりお礼申し上げます。では・・・。