ＥＸＣＥＬで分かれたシート間の同一データ行を自動削除して結合したい

質問

ＥＸＣＥＬで、シート１、シート２に分かれたデータがあります。

それぞれのシート間でＣ列～Ｆ列の値が重複している行、シート１側のＧ列の数値がマイナス
になっている行を自動で削除してからデータを１つのシートに結合する方法を探しています。

条件は、シート１側の重複データ行のみを削除し、シート２側のデータが必ず残る方法であ
る必要があります。Ｇ列のマイナス行を削除するのはシート１側のみです。

シート１がＡ列～Ｉ列、約３万行、シート２がＡ列～Ｋ列、約１千行くらいです。
シート２側のみＪ列～Ｋ列（数値データが入っています）が存在しますが、シート１側は空欄です。
列の数は変わりませんが、行数が都度変動しますのでマクロでコピー先のセル位置を決め打ちする
事が出来ません。

１つのシート上で重複するデータを削除する方法は見つける事が出来たのですが、残す方のデータ
が指定出来ないのと、複数のシート上の重複データを削除する方法が見つかりませんでした。

何か良い方法がありましたら、ご教授下さい。

回答No.9

merlionXX · ベストアンサー

こんばんは。merlionXXです。
すっかり高速化にはまってしまいました。（笑）

これでどうでしょう？
作業列をつかう方法です。Sheet1,2それぞれのIV列（最右列）にいったん式を入れ、最後に削除しています。
ためしたところ、30000行*1000行検索でも1分かかりません。

Sub 高速化test06()
Dim a, b, lr, i, n

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Sheets("Sheet1")
lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行

.Range("IV1:IV" & lr).Value = "=RC[-253]&""_""&RC[-252]&""_""&RC[-251]&""_""&RC[-250]"
Sheets("Sheet2").Range("IV1:IV" & lr2).Value = "=RC[-253]&""_""&RC[-252]&""_""&RC[-251]&""_""&RC[-250]"

For i = lr To 1 Step -1

n = Application.Match(.Range("IV" & i), Sheets("Sheet2").Range("IV1:IV" & lr2), 0)
If Not IsError(n) Then
.Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If

Next i

.Columns("IV").Delete Shift:=xlToLeft
Sheets("Sheet2").Columns("IV").Delete Shift:=xlToLeft

End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

お礼

merlionXXさん、こんばんは。
高速化の世界に引き込んでしまい申し訳けございません……

今回のも、さっそく実行してみましたところ…、はっ速い！！　わずか３分でした。１時間でも速いと驚いていたのに、今回のはあまりの速さに言葉も出ません。大変素晴らしいプログラムを有難うございました。

回答No.11

merlionXX

実証データをありがとうございました。
わたしも今回はとても勉強になりました。AWG985さんの質問とtaocat道士様の一言のおかげです。お二人にはとても感謝しています。

お礼

大変素晴らしいプログラムを本当にありがとうございました。
貴重なお時間を割いてのご回答に心より感謝いたします。

補足

お蔭様で期待以上の結果を得る事ができましたので、これにて質問を
クローズさせて頂きます。ご回答ありがとうございました。

回答No.10

merlionXX

作業列を使わない高速化にも成功しました。
30000行*1000行検索でも30秒程度でした。

Sub 高速化test08()
'Sheets("Sheet3").Range("A1") = Time
Dim a As Variant, b As Variant, lr As Long, lr2 As Long, i As Long, x As Range, xa As String

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Sheets("Sheet1")

lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行

For i = lr To 1 Step -1

Set x = Sheets("Sheet2").Range("C1:C" & lr2).Find(What:=.Range("C" & i).Value) 'C列検索
'
If Not x Is Nothing Then 'C列一致なら

xa = x.Address 'Sheet2で一致したアドレス

a = Array(.Range("D" & i).Resize(1, 3).Value) 'Sheet1,D~Fを配列に
b = Array(x.Offset(0, 1).Resize(1, 3).Value) 'Sheet2,D~Fを配列に

If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then '配列を比較
.Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If

Do

Set x = Sheets("Sheet2").Range("C1:C" & lr2).FindNext(x) '連続検索

If Not x Is Nothing Then 'C列一致なら

a = Array(.Range("D" & i).Resize(1, 3).Value) 'Sheet1,D~Fを配列に
b = Array(x.Offset(0, 1).Resize(1, 3).Value) 'Sheet2,D~Fを配列に

If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then '配列を比較
.Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If

End If

Loop While x.Address <> xa ' 同じアドレスの再検索にならない限り繰り返し

End If

Next i

End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
'Sheets("Sheet3").Range("A2") = Time
End Sub

補足

こちらも実行してみましたところ、７分でした。結果をまとめると

テストに使用したデータ数：Sheet1: 20,000行、Sheet2: 4,000行、重複件数3600行。

No.1　約３時間
No.7 約１時間
No.8 約１時間３０分
No.9 約３分
No.10 約７分

No.9が一番高速ですね。テストに使ったデータは全て同じ物です。
No.8のＦ列をキーにすると何故か30分遅くなり、Ｆ列のデータをＣ列と入れ替えてNo.7のプログラムでテストすると１時間でした。

回答No.8

merlionXX

> 速いですね。これなら今後データが増えて行っても十分対応できます。

お喜びいただけてわたしもうれしいです。

> マッチしにくいのはＦ列の文字列データになります。Ｃ～Ｄ列は分類用の文字列、Ｅ列は日付です。

「マッチしにくい」＝「Sheet1と2で、同一文字列となる数が一番少ない」という理解でいいですね？
F列が一致してはじめてC～Eの完全一致チェックを行いますので、マッチしにくい列をキーに最初のチェックをかけるのが一番効率的です。
F列での場合は以下のコードとなります。
お試しいただき、所要時間を比較してみてください。

Sub 高速化06()
Dim a, b, lr, lr2, i, n
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Sheet1")
lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行
For i = lr To 1 Step -1
For n = 1 To lr2
If .Range("F" & i) = Sheets("Sheet2").Range("F" & n) Then 'F列が一致した場合
a = Array(.Range("C" & i & ":E" & i).Value) 'Sheet1,C~Eを配列に
b = Array(Sheets("Sheet2").Range("C" & n & ":E" & n).Value) 'Sheet2,C~Dを配列に
If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then '配列を比較
.Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If
End If
Next n
Next i
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

回答No.7

merlionXX

とりあえず、C列をキーにして比較してみました。
実際にSheet1のA1:F30000に30,000行、Sheet2A1:F1000に1,000行のデータを入れて下記のマクロを走らせましたが問題なく作動しました。ただし今度は秒速とはいかず、10分程度かかりました。
下記マクロは高速化を図るため、まずC列のみを比較し、C列が一致した場合、D～F列を比較しています。

Sub 高速化05()
Dim a, b, lr, lr2, i, n
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Sheets("Sheet1")
lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行
For i = lr To 1 Step -1
For n = 1 To lr2
If .Range("C" & i) = Sheets("Sheet2").Range("C" & n) Then 'C列が一致した場合
a = Array(.Range("D" & i & ":F" & i).Value) 'Sheet1,D~Fを配列に
b = Array(Sheets("Sheet2").Range("D" & n & ":F" & n).Value) 'Sheet2,D~Fを配列に
If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then '配列を比較
.Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If
End If
Next n
Next i
End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

お礼

ご回答ありがとうございます。
早速テストしてみましたら３時間から１時間まで短縮されました。速いですね。これなら今後データが増えて行っても十分対応できます。

回答No.6

merlionXX

すみません。
原因がわかりました。高速化ばかり考えていたため、Sheet1の表内でも各列にも重複する文字列が当然入るだろうということを考慮していませんでした。
最初の回答はSheet1と2を順列組み合わせで照合しているので問題なかったのですが・・・。
質問です。
Sheet1とSheet2の表で一番マッチしにくいと思われるのはC～F列のどれですか？それにより作り直します。

補足

ご回答ありがとうございます。
マッチしにくいのはＦ列の文字列データになります。Ｃ～Ｄ列は分類用の文字列、Ｅ列は日付です。もし数値データの方が高速になるのでしたら、Ｃ～Ｄ列の代わりにＭ～Ｎ列（半角数字）を使う事もできます。

回答No.5

merlionXX

すみません、さきほどのコードにミスがありました。
差し替えます。

Sub 高速化test04()
'Sheets("Sheet4").Range("A1") = Now
Dim a, b, lr, i, n
Dim rngT As Range, rngC As Range, rngR As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Sheets("Sheet1")
lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行

Set rngT = .Range("G1:G" & lr).SpecialCells(xlCellTypeConstants, xlNumbers)

For Each rngC In rngT
If rngC < 0 Then

If rngR Is Nothing Then
Set rngR = rngC
Else
Set rngR = Union(rngR, rngC)
End If
End If
Next rngC

If Not rngR Is Nothing Then
rngR.EntireRow.Delete 'G列のマイナス行を削除
Set rngR = Nothing
End If
Set rngT = Nothing

For i = lr To 1 Step -1

n = Application.Match(.Range("C" & i), Sheets("Sheet2").Range("C1:C" & lr2), 0)
If Not IsError(n) Then
a = Array(.Range("D" & i & ":F" & i).Value)
b = Array(Sheets("Sheet2").Range("D" & n & ":F" & n).Value)
If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then .Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If

Next i

End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

'Sheets("Sheet4").Range("A2") = Now
End Sub

なおシート１側のＧ列の数値がマイナスのものを削除のところですが、高速化したものは、ここが数値でマイナスが入っているものだけを対象にしています。（計算式の結果がマイナスのものは対象としていない。不都合がありましたら言ってください）

補足

ご回答ありがとうございます。
テストしてみましたところ、重複行の削除がうまく行かないようで、
Ｇ列がマイナスになっている行と数行だけ消えている感じです。

Ｃ列（文字列）、Ｄ列（文字列）、Ｅ列（日付）、Ｆ列（文字列）と
いう設定になっていますが、関係ありますでしょうか。
（Ｃ列とＤ列の変わりにＭ列とＮ列の数値データを使う事も出来ます）

Ｇ列がマイナスの行削除は空白行を削除している別モジュールにまとめ
ましたので、重複行の削除部分のみご指摘頂ければ幸いです。

回答No.4

merlionXX

AWG985さん、そしてtaocatお師匠様、ご覧になっていますか？
やっと高速化に成功しました。
前のだと数時間はかかりましたが、今度のは秒速です。
いかがでしょうか？

Sub 高速化test03()
'Sheets("Sheet4").Range("A1") = Now
Dim a, b, lr, i, n
Dim rngT As Range, rngC As Range, rngR As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Sheets("Sheet1")
lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行

Set rngT = .Range("C1:C" & lr).SpecialCells(xlCellTypeConstants, xlNumbers)

For Each rngC In rngT
If rngC < 0 Then

If rngR Is Nothing Then
Set rngR = rngC
Else
Set rngR = Union(rngR, rngC)
End If
End If
Next rngC

If Not rngR Is Nothing Then
rngR.EntireRow.Delete
Set rngR = Nothing
End If
Set rngT = Nothing

For i = lr To 1 Step -1

n = Application.Match(.Range("C" & i), Sheets("Sheet2").Range("C1:C" & lr2), 0)
If Not IsError(n) Then
a = Array(.Range("C" & i & ":F" & i).Value)
b = Array(Sheets("Sheet2").Range("C" & n & ":F" & n).Value)
If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then .Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
End If

Next i

End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

Exit Sub
'Sheets("Sheet4").Range("A2") = Now
End Sub

お礼

大変素晴らしいご回答、ありがとうございます。
前のですと約３時間でしたので、更に短くなるとは驚きです。
早速組み込んで実行してみます。結果はまたご報告致します。

回答No.3

merlionXX

merlionXXです。
う～ん、そうか件数がめちゃくちゃ多いんでしたよねえ。
何百件かのサンプルデータでは試したのですが、30,000,000回のループでは時間がかかりすぎるかも。 （￣□￣；）！！

さすがお師匠様はよく見ていらっしゃる。
かといって、わたくしめに思いつくのは、(゜〇゜;)?

Application.ScreenUpdating = False '画面更新を一時停止
Application.Calculation = xlCalculationManual '関数自動計算の停止

くらいなのですが、これだけでは焼け石に水ですね。
やはりお師匠様におすがりしなくては。
まだまだ素人のmerlionXXでした。

回答No.2

taocat

質問者さん、merlionさん、こんにちは。

merlionさん素晴らしい回答ですね。
そろそろVBAエキスパートさんとお呼びしなければならないかも知れませんねぃ。(^o^)/

なので敢えて一言。

今回のは質問にもありますように

＞シート１がＡ列～Ｉ列、約３万行
＞シート２がＡ列～Ｋ列、約１千行

となってますので回答のForのネストでは単純に考えて
30,000×1000=30,000,000回のループになりますよね。
これではちょっと時間が掛かりすぎるかもしれませんね。
お暇なときにでも時間短縮の方法を考えてみてくださいな。
余計な一言、老婆心からということでお許しください。
以上です。

回答No.1

merlionXX

１．シート１のＧ列のマイナス行を削除
２．シート２のＣ列～Ｆ列の配列と、シート１のＣ列～Ｆ列の配列が完全一致する場合、シート１の該当行を削除

という理解でいいですか？
VBAコードのサンプルです。

Sub test01()
Dim a, b, lr, i, n

With Sheets("Sheet1")
lr = .Range("A65536").End(xlUp).Row 'Sheet1最終行
lr2 = Sheets("Sheet2").Range("A65536").End(xlUp).Row 'Sheet2最終行

For i = lr To 1 Step -1
If .Range("G" & i) < 0 Then .Rows(i).Delete 'G列のマイナス行を削除
Next i

For i = lr To 1 Step -1
For n = 1 To lr2
a = Array(.Range("C" & i & ":F" & i).Value)
b = Array(Sheets("Sheet2").Range("C" & n & ":F" & n).Value)
If Join(Application.Index(a, 0)) = Join(Application.Index(b, 0)) Then .Rows(i).Delete 'Sheet2と重複するC~F列がある行を削除
Next n
Next i

End With
End Sub

お礼

早速のご回答ありがとうございます。
お蔭様で思い通りの結果を得る事が出来ました。