重複行を完全削除するエクセルのマクロ

質問

Sub sakujyo()
Dim i, ii As Long
For i = 1 To Range("a65336").End(xlUp).Row
For ii = Range("a65336").End(xlUp).Row To i + 1 Step -1
If Cells(i, 2).Value = Cells(ii, 2).Value _
And Cells(i, 4).Value = Cells(ii, 4).Value _
And Cells(i, 5).Value = Cells(ii, 5).Value Then
Dim iii As Byte
iii = 1
Rows(ii).Delete Shift:=xlUp
End If
Next ii
If iii = 1 Then Rows(i).Delete Shift:=xlUp
iii = 0
Next i
End Sub

データーが下の表のように入っております。
　　　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｅ　　　　Ｆ
１　　1/26　　a1234　　fdsa　　5000　　Ｃ1
２　　1/27　　a4567　　sdfa　　4000　　Ｔ2
３　　1/28　　a1234　　dfsa　　5000　　Ｃ1
４　　1/30　　b4567　　asdf　　6600　　Ａ2
５　　2/10　　b4567　　fsda　　6600　　Ａ2
６　　2/10　　a1234　　afds　　5000　　Ｃ1

Ｂ列、Ｅ列、Ｆ列が完全一致（重複１行目と３行目と６行目・４行目と５行目）で削除し結果的に２行目だけ残る方法がしたいのですが、このマクロですと少ないデータですとうまく動くのですが、『大量のデータを一気に削除出来ない』、『同じ重複が３つ以上のデータが多数ある場合データが削除されずに残ってしまう』エラーが出てしまいます。どうかお教えください。

回答No.1

n-jun · ベストアンサー

シート１のデータをシート２に書き出します。
Ｄ列については不明ですが、Ｂ・Ｅ・Ｆ列の重複を判定しています。

書き出し結果と速度に問題があるか、ブックをバックアップしてから試してみて下さい。

Sub　try()
　Dim　myDic　As　Object
　Dim　i　As　Long,　j　As　Long
　Dim　m　As　Long,　st　As　String
　Dim　v,　vv

　Set　myDic　=　CreateObject("Scripting.Dictionary")

　With　Worksheets("Sheet1")
　　　　　　v　=　.Range(.Range("A1"),　.Cells(Rows.Count,　1).End(xlUp).Resize(,　6))
　　　　　　For　i　=　1　To　UBound(v,　1)
　　　　　　　　　　st　=　v(i,　2)　&　"_"　&　v(i,　5)　&　"_"　&　v(i,　6)
　　　　　　　　　　myDic(st)　=　myDic(st)　+　1
　　　　　　Next
　End　With

　ReDim　vv(1　To　6,　1　To　1)
　j　=　1

　For　i　=　1　To　UBound(v,　1)
　　　　　st　=　v(i,　2)　&　"_"　&　v(i,　5)　&　"_"　&　v(i,　6)
　　　　　If　myDic(st)　=　1　Then
　　　　　　　　For　m　=　1　To　6
　　　　　　　　　　　　vv(m,　j)　=　v(i,　m)
　　　　　　　　Next
　　　　　　　　j　=　j　+　1
　　　　　　　　ReDim　Preserve　vv(1　To　6,　1　To　j)
　　　　　End　If
　Next

　With　Worksheets("Sheet2")
　　　　　　.Range("A1").Resize(j　-　1,　6).Value　=　_
　　　　　　Application.Transpose(vv)
　　　　　　.Range("A:A").NumberFormatLocal　=　"m/d"
　End　With

　Set　myDic　=　Nothing
　Erase　v,　vv
End　Sub

ご参考になれば。

お礼

すばやい対応ありがとうございます。
問題は、ございませんでした。とても早く動いたため驚いております。
大変助かりましたありがとうございます。また、機会がございましたら宜しくお願いいたします。

回答No.4

web2525

No2の回答と同意見になってしまうのですが、

マクロで重複検査を実施するよりもCOUNTIFで重複チェックを行う方が容易かと思われます。
G列に
=B1&E1&F1
H列に
=COUNTIF(H$1:H1,H1)
でオートフィルターでH列を1以外で指定し残っている行を削除。

複数のシートにマクロで対応する必要があるのであれば
H列を調べて1以外の行を削除する部分だけマクロ化すれば簡単に作成できると思いますよ。

回答No.3

cj_mover

#2です。訂正だけ。

誤り> I列2行め以下 =IF(COUNTIF($H$1:$H$10000,H2),"Del",0)
↓
I列2行め以下 =IF(COUNTIF(H$1:H1,H2),"Del",0)

失礼いたしました。

お礼

勉強になりましたありがとうございます。

回答No.2

cj_mover

こんにちは

初見での印象だけで書きますが、
VBAのコードにも問題はあるようですが、それ以前に、
なぜ手作業でやらないのでしょうか？
VBAの学習が目的とも思えないし、手作業の方が早く片付くような気がします。
（本稿は着想のままExcelがない環境で書いてますからヒント程度に）

///
作業セルを２列（仮にH列とI列）用意して、
　H列　=B1&":"&E1&":"&F1
　I列２行め以下　=IF(COUNTIF($H$1:$H$10000,H2),"Del",0)
のように数式を配置して、
I列に対してジャンプ機能（数式 文字列）で削除対象を選択、
（必要ならソートを挟む）とか。
///

マクロを作るにしても、
ExcelにできることはExcelにやらせる、方法を排除したら、
VBAである意味もないように思います。
マクロの記録でも少し手を加えるだけで十分なものが得られるでしょうし。

マクロを考える際、
　「最終的にExcelの機能（この場合は行削除のこと）を使う」処理で
　「条件づけ（検索）にExcelの機能が使える」
ならば、
基本的にExcelの機能を軸に作成することをお奨めします。
　エラーを出さずに大量のデータを一括処理・・・Excelが得意なことですよね？
その上で、不足が出たなら、また別の方法を考えればよいのかと。

VBAの質問と括らない方が有益な回答が得られるように私には思えました。

意図から外れているようでしたらスミマセン。
なお、本スレッドに対して、これ以上書くつもりはないので、悪しからず。