エクセルVBAで不一致に空白セルを挿入

質問

エクセル2010です。
A、B列ともソートされています。
ごく少数ですが同一列内に重複するデータもあります。
そして
A列に、1行目からA、B、C、E、F、F、H
B列に、1行目からA、B、D、E、F、G、I
（カンマは実際にはありません。）
というような文字列データがある場合
別シートに
A列に、1行目からA、B、C、空、E、F、F、空、H、空、
B列に、1行目からA、B、空、D、E、F、空、G、空、I、
（空は空白セルの意味です。）
というように、お互いが一致しない場合は空白で飛ばし、一致するものは同じ行にするにはどのような方法がよろしいでしょうか？
例のように少ないデータなら目で見て手作業でできますが、実際は千件以上のデータです。
VBAでも関数でも結構です。よろしくお願いします。

回答No.4

watabe007 · ベストアンサー

>不一致に空白セルを挿入
データが千件以上あれば毎回セルを挿入していたのでは
時間もかかるので配列を使って一気に処理しました。
Sub Test()
　　Dim v(), i As Long, j As Long, k As Long

　　i = 1: j = 1: k = 0
　　Do
　　　　ReDim Preserve v(1, k)
　　　　If Cells(i, "A").Value = "" Or Cells(j, "B").Value = "" Then
　　　　　　v(0, k) = Cells(i, "A").Value
　　　　　　v(1, k) = Cells(j, "B").Value
　　　　　　i = i + 1: j = j + 1
　　　　ElseIf Cells(i, "A").Value = Cells(j, "B").Value Then
　　　　　　v(0, k) = Cells(i, "A").Value
　　　　　　v(1, k) = Cells(j, "B").Value
　　　　　　i = i + 1: j = j + 1
　　　　ElseIf Cells(i, "A").Value > Cells(j, "B").Value Then
　　　　　　v(0, k) = ""
　　　　　　v(1, k) = Cells(j, "B").Value
　　　　　　j = j + 1
　　　　ElseIf Cells(i, "A").Value < Cells(j, "B").Value Then
　　　　　　v(0, k) = Cells(i, "A").Value
　　　　　　v(1, k) = ""
　　　　　　i = i + 1
　　　　End If
　　　　k = k + 1
　　Loop Until Cells(i, "A").Value = "" And Cells(j, "B").Value = ""
　　Worksheets("Sheet2").Range("A1").Resize(UBound(v, 2) + 1, 2).Value = Application.Transpose(v)
End Sub

お礼

watabe007 さん、最高です！！
1千件超の不揃いデータが瞬時で「左右対照表」に変身しました。
配列ってすごいですね。
これで安心して月曜日会社に行けます。
感謝感激です。
ありがとうございました！

回答No.6

MackyNo1

>やはりうまくいきません。
以下のようになってしまいます。

質問内容をよく見たら、A列のデータに重複があるのですね。

このケースでは提示したような関数と行の挿入操作では簡単に対応することができません。

データの順が変わってもよいなら（重複データなので、おそらく大丈夫だと思いますが）、以下のような手順でご希望のリストを作成することもできます。

準備としてB列のデータを切り取り、E列に貼り付けます。
次に「データ」タブの「詳細設定」から、リスト範囲にA列のデータ範囲、検索条件範囲にE列のデータ範囲を選択し、OKして、フィルタされた状態でB1セルに以下の式を入力し下方向にオートフィルします。
=IF(COUNTIF($A$1:A1,A1)=1,A1,"")

フィルタモードを解除し、同様に、「データ」タブの「詳細設定」から、リスト範囲にE列のデータ範囲、検索条件範囲にA列のデータ範囲を選択し、OKして、フィルタされた状態でD1セルに以下の式を入力し下方向にオートフィルします。
=IF(COUNTIF($E$1:E1,E1)=1,E1,"")

フィルタモードを解除し、D列とE列のデータ範囲を選択し「フィルタ」でD列の空白セルのみ抽出し、このデータ範囲をコピーし、A列のデータ範囲の後に「貼り付け」して、フィルタモードを解除すればご希望のデータ構成になっていますので、数式セル部分をコピーし、適当なセルに「値」貼り付けしてください。

ちなみに、空白に見えているセルには、本当の空白セルと空白文字列のセルが混入していますので、この空白文字列を空白セルにしたいなら、その列を1列だけ選択して、「データ」「区切り位置」で「完了」してください。

お礼

何度もありがとうございます。
重複は本来あってはならないのですが、まれに発生することがあり、それのチェックもかねてこのような表の作成をしているのです。
また件数も1千件以上あるので、今回はVBAで対応することといたします。
ありがとうございました。

回答No.5

MackyNo1

No1の回答の訂正です。

同様にC1セルに「=COUNTIF(A:A,B1&"")」と入力し、B列のデータ数分だけオートフィルコピーし、・・・の操作の前に以下の操作を追加してください。

A列を選択して、Ctrl+Gでジャンプファイアログを出して「セル選択」「空白セル」でA列の空白セルを選択して、右クリックから「削除」で「上方向にシフト」して、元のA列のデータに戻してから、B列は空白セルがある状態で上記の操作を続けてください（COUNTIF関数に&""がついていることに注意してください）。

あるいは、元データをコピーしたシートで作業し、最初の操作でB列のデータを作成して別シートにコピーし、そのB列のデータがあるシートのA列に元データのA列のデータを上書きして作業するほうが簡単かもしれません。

お礼

やはりうまくいきません。
以下のようになってしまいます。

A 　A
B 　B
C
　 　D
E 　E
F 　F
F 　G

H 　I

回答No.3

watabe007

>というような文字列データがある場合別シートに
そのまんま別シートのABにコピーした後のコードを書いています。
Dim i As Long
i = 1
Do
　　If Cells(i, "A").Value = "" Or Cells(i, "B").Value = "" Then
　　ElseIf Cells(i, "A").Value > Cells(i, "B").Value Then
　　　　Cells(i, "A").Insert Shift:=xlDown
　　ElseIf Cells(i, "A").Value < Cells(i, "B").Value Then
　　　　Cells(i, "B").Insert Shift:=xlDown
　　End If
　　i = i + 1
Loop Until Cells(i, "A").Value = "" And Cells(i, "B").Value = ""

お礼

なんと！
こんなに短いコードでできてしまうのですか・・・・。
すごいです。
ありがとうございました！

回答No.2

tom04

こんにちは！
VBAでの一例です。

元データはSheet1の1行目からあるとします。
Sheet2とSheet3を作業用のSheetとして使用していますので、
Sheet2およびSheet3は全く使用していない状態にしておいてください。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペースト　→　Excel画面に戻り、マクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long, cnt As Long
Dim c As Range, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.ClearContents
With Worksheets("Sheet1")
If .Cells(Rows.Count, "A").End(xlUp).Row > .Cells(Rows.Count, "B").End(xlUp).Row Then
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
Else
lastRow1 = .Cells(Rows.Count, "B").End(xlUp).Row
End If
wS2.Range("A1") = "ダミー"
Range(.Cells(1, "A"), .Cells(lastRow1, "A")).Copy wS2.Range("A2")
Range(.Cells(1, "B"), .Cells(lastRow1, "B")).Copy wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
lastRow2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS2.Cells(1, "A"), wS2.Cells(lastRow2, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS2.Range("A:A").Copy wS3.Range("A1")
wS2.ShowAllData
wS2.Range("A:A").Delete
lastRow2 = wS3.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS3.Cells(1, "A"), wS3.Cells(lastRow2, "A")).Sort key1:=wS3.Range("A1"), order1:=xlAscending, Header:=xlYes
wS3.Range("A1").Delete shift:=xlUp
For i = wS3.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
cnt = WorksheetFunction.Max(WorksheetFunction.CountIf(.Range("A:A"), wS3.Cells(i, "A")), _
WorksheetFunction.CountIf(.Range("B:B"), wS3.Cells(i, "A")))
If cnt > 1 Then
wS3.Cells(i + 1, "A").Resize(cnt - 1).Insert shift:=xlDown
End If
Next i
For i = 1 To lastRow1
For j = 1 To 2
Set c = wS3.Range("A:A").Find(what:=.Cells(i, j), LookIn:=xlValues, lookat:=xlWhole)
If wS2.Cells(c.Row, j) = "" Then
wS2.Cells(c.Row, j) = .Cells(i, j)
Else
cnt = c.Row
Do Until wS2.Cells(cnt, j) = ""
cnt = cnt + 1
Loop
wS2.Cells(cnt, j) = .Cells(i, j)
End If
Next j
Next i
End With
wS3.Cells.Clear
Application.ScreenUpdating = True
wS2.Activate
MsgBox "処理完了"
End Sub 'この行まで

※　若干時間を要すると思います。
※　元データは並び替えしていなくても構いません。m（_ _）m

お礼

すごい大作ですね！
ならべかえしなくても良い分、時間がかかるのですね。
できました。ありがとうございます。

回答No.1

MackyNo1

Excelの機能を使いこなす必要がありますが、以下のような操作をすれば、Excelの一般機能だけで簡単にまとめてデータをご希望の形に成型することができます。

C1セルに「=COUNTIF(B:B,A1)」の式を入力し、A列のデータ数分だけオートフィルコピーし、そのままCtrl＋Fで検索ダイアログを出し、「オプション」ボタンをクリックし、検索対象を「値」にして「セル内容が完全に同一であるものだけを対象にする」のチェックをいれて、検索する文字列に「0」をいれて「すべて検索」し、Ctrl+Aで対象セルを選択して、対象セル上で右クリックし「挿入」で「行全体」を選択します。
この操作で作成されたB列のデータを新規シートのB列にコピー貼り付けします。

同様にC1セルに「=COUNTIF(A:A,B1&"")」と入力し、B列のデータ数分だけオートフィルコピーし、そのままCtrl＋Fで検索ダイアログを出し、同様に検索する文字列に「0」をいれて「すべて検索」し、Ctrl+Aで対象セルを選択して、対象セル上で右クリックし「挿入」で「行全体」を選択し、A列のデータ範囲をコピー貼り付けすれば完成です。

お礼

ありがとうございました。
わたしのやりかたがわるいのか、どうもうまくいきませんでした。