条件にて行削除をするをマクロで高速化したい

質問

シート（最初）のA,B,C列を連結した値と
シート（残）のA,B,C列を連結した値を照合させ
同じ値の場合は
シート（残）の該当行を削除です。
シート（最初）は6,182行
シート（残）は7,561行です。
VLookupを使って処理時間5分です。
VLookupを使わない記述で25分です。
20,000行位のデータを処理したいのですが時間が不安です。
別スレで
「VLookupで処理3分をdictionaryオブジェクトで1秒以内にする方法」を
教えていただきましたが、流用ができません。
シート（残）内にもシート（最初）内にも重複行はありません。
私の記述は「F列を検索用に使用」となっていて
F列にデータがある場合、都度記述を書換えないと
使えないので、そこも対応したいです。
照合させる値はA,B,Cの連結値というのは変わらないのですが
データがある範囲は都度変化する為です。
・A～E列とかA～H列とか
・シート残はA～E列、シート最初はA～G列とか
記述そのものを教えてください。よろしくお願いします。

Sub 自動重複削除F列使用()
'シート（最初）のA,B,C列とシート（残）のA,B,C列が一致した行は
'シート残の行を削除
'F列を検索値として使用。
Dim Line As Long
Dim LastRow As Long
Dim myRange As Range
Dim Flag
'シート「最初」のF1に、A,B,C列を結合した値を転記
With Sheets("最初")
Set myRange = .Range("F2:F" & .Cells(Rows.Count, "A").End(xlUp).Row)
.Range("F2").FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]"
'シート「最初」のF2からデータのあるところまで
'F1の規則でデータ貼付
.Range("F2").AutoFill Destination:=myRange
End With
'シート「残」のF1に、A,B,C列を結合した値を転記
Sheets("残").Select
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("F2").FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]"
'シート「最初」のF2からデータのあるところまで
'F1の規則でデータ貼付
Range("F2").AutoFill Destination:=Range("F2:F" & LastRow)
On Error Resume Next
'双方のシートのF列を照合させ、ヒットした行は
'シート「残」から行削除をする
For Line = LastRow To 2 Step -1
Flag = WorksheetFunction.VLookup(Cells(Line, 6).Value, myRange, 1, 0)
If Err.Number = 0 Then
Rows(Line).Delete xlUp
Else
Err.Clear
End If
Next Line
'検索に使用したＦ列を削除
Sheets("残").Select
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Sheets("最初").Select
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Sheets("残").Select
Range("A1").Select
End Sub

●別方法
Sub 自動重複行削除F列未使用超遅()
'VLOOKUP無
'シート（最初）のA,B,C列とシート（残）の
'A,B,C列が一致した行はシート（残）の行を削除
Dim ws1, ws2 As Worksheet
Dim i, j As Long
Set ws1 = Worksheets("最初")
Set ws2 = Worksheets("残")
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If ws1.Cells(i, 1) = ws2.Cells(j, 1) And ws1.Cells(i, 2) = ws2.Cells(j, 2) And _
ws1.Cells(i, 3) = ws2.Cells(j, 3) Then
ws2.Rows(j).Delete (xlUp)
End

回答No.12

merlionXX · ベストアンサー

merlionXXです。
やはり順列組み合わせは効率が悪すぎるのでご要望のDictionaryObjectを使うことにしました。
1万行で試しましたが0.3秒かかりませでした。

Sub testA_E列02()
　　Dim t As Single
　　Dim myDic As Object
　　Dim myS, myZ, myX, mySS, myZZ
　　Dim i As Long, j As Long, n As Long, c As Long
　　t = Timer
　　With Sheets("最初") 'A_C列を配列mySに
　　　　myS = .Range("A2:AC" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
　　End With
　　ReDim mySS(1 To UBound(myS))
　　For i = 1 To UBound(myS)
　　　　For j = 1 To 3
　　　　　　mySS(i) = mySS(i) & myS(i, j)
　　　　Next j
　　Next i
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 1 To UBound(myS)
　　　　myDic(mySS(i)) = ""
　　Next i
　　With Sheets("残") 'A_E列を配列myZに
　　　　myZ = .Range("A2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
　　End With
　　c = UBound(myZ, 2) + 1
　　ReDim Preserve myZ(1 To UBound(myZ, 1), 1 To c) '1列追加
　　ReDim myZZ(1 To UBound(myZ))
　　For i = 1 To UBound(myZ)
　　　　For j = 1 To 3
　　　　　　myZZ(i) = myZZ(i) & myZ(i, j)
　　　　Next j
　　Next i
　　For i = 1 To UBound(myZ)
　　　　If myDic.Exists(myZZ(i)) Then
　　　　　　myZ(i, c) = 1
　　　　End If
　　Next i
　　ReDim myX(1 To UBound(myZ, 1), 1 To UBound(myZ, 2)) As String '配列myX用意
　　For i = 1 To UBound(myZ, 1)
　　　　If myZ(i, c) <> 1 Then
　　　　　　n = n + 1
　　　　　　For j = 1 To c
　　　　　　　　myX(n, j) = myZ(i, j)
　　　　　　Next j
　　　　End If
　　Next i
　　Application.ScreenUpdating = False
　　With Sheets("残")
　　　　.Range("A2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
　　　　.Range("A2").Resize(n, UBound(myZ, 2) - 1).Value = myX
　　End With
　　Application.ScreenUpdating = True
　　Debug.Print Timer - t
End Sub

お礼

凄いです。
6,500行と7,131行で1秒かからず
11,000行と13,000行でも体感的には同じ速さでした。
やはりこれを見せていただきますと
今回のように質問をしたくなります。

ところで、今回は
シート最初もシート残もＡ～Ｅ列でしたが
最初の質問にありますように
データによってはＡ～Ｇ列とか
シート（最初）とシート（残）の列数が相違する場面が出てきます。
配列に取り込む以上、都度書き換えするしかないという
解釈でよろしいのでしょうか？

またシート（最初）の方は
配列に取り込むのは照合するA,B,C列だけなので
別にデータがＡ～Ｅ列だろうがＡ～Ｇ列だろうが
記述変更は関係ないという解釈で正しいでしょうか？

でシート（残）は全部配列に取り込むので
列が変化した場合は記述の変更が必要という解釈で
よろしいでしょうか？

で今回はＡ～Ｅ列ですが
例えばＡ～Ｇ列の場合

myZ = .Range("A2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).Value

↓
myZ = .Range("A2:G" & .Cells(Rows.Count, "A").End(xlUp).Row).Value

.Range("A2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents

↓
.Range("A2:G" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents

の２ケ所の変更だけでよろしいのでしょうか？

回答No.8

end-u

>・１件ずつ重複チェックをするのではなく別作業列に数式を入れてまとめてチェックする。
ここ、遅いですね。使い物にならないです。失礼しました..orz
この部分だけDictionaryを使った折衷案。
#シート名やデータ範囲などは実状に合わせて適宜、手を入れてください。

Sub try_1()
　　'VBE[ツール]-[参照設定]で"Microsoft Scripting Runtime"参照
　　Dim dic As Dictionary
　　Dim r1　As Range　　 '照合元（残）
　　Dim r2　As Range　　 '照合先（最初）
　　Dim r　 As Range　　 '削除起点
　　Dim i　 As Long
　　Dim v() As Variant　 '照合元
　　Dim w() As Variant　 '照合先
　　Dim flg() As Boolean '照合結果

　　'データ範囲のIV列を取得
　　With Sheets("sheet1").Range("A1").CurrentRegion.EntireRow
　　　　Set r1 = Intersect(.Cells, .Offset(1), .Columns("IV"))
　　End With
　　With Sheets("sheet2").Range("A1").CurrentRegion.EntireRow
　　　　Set r2 = Intersect(.Cells, .Offset(1), .Columns("IV"))
　　End With
　　r1.Formula = "=A2&B2&C2"
　　v() = r1.Value
　　ReDim flg(1 To UBound(v), 0) As Boolean
　　r1.ClearContents
　　r2.Formula = "=A2&B2&C2"
　　w() = r2.Value
　　'作業列削除
　　r2.EntireColumn.Delete

　　Set dic = New Dictionary
　　'Dictionaryに照合先を登録
　　For i = 1 To UBound(w)
　　　　dic(CStr(w(i, 1))) = Empty
　　Next
　　'照合元と照合先の重複チェック
　　For i = 1 To UBound(v)
　　　　flg(i, 0) = dic.Exists(CStr(v(i, 1)))
　　Next
　　'照合結果をIV列に書き戻し
　　r1.Value = flg()

　　'データ範囲のみソート
　　r1.EntireRow.Sort Key1:=r1.Item(1), _
　　　　　　　　　　　Order1:=xlAscending, _
　　　　　　　　　　　Header:=xlNo, _
　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　Orientation:=xlTopToBottom
　　'重複データの先頭を検索
　　Set r = r1.Find(What:="TRUE", _
　　　　　　　　　　LookIn:=xlValues, _
　　　　　　　　　　LookAt:=xlWhole)

　　If Not r Is Nothing Then
　　　　'重複データあれば行全体削除
　　　　Range(r, r1(r1.Count)).EntireRow.Delete
　　End If
　　'作業列削除
　　r1.EntireColumn.Delete

　　Set dic = Nothing
　　Set r1 = Nothing
　　Set r2 = Nothing
　　Set r = Nothing
End Sub

最速ではないです。速度より理解し易さ重視..（多分。
理解した上でなら、メンテナンスもそんなに大変じゃないと思います。

お礼

ありがとうございました。

コンパイルエラー
ユーザー定義型は定義されていません

Dim dic As Dictionaryでとまります。

'VBE[ツール]-[参照設定]で"Microsoft Scripting Runtime"参照
↓
参照可能なライブラリファイル
で
Microsoft Scripting Runtime
というのは無かったのですが．．．．．

初めて開くウィンドーですし
ユーザー定義型？
全然分かりません。

＞理解した上でなら

理解は私では難しそうです。
申し訳ありません。

回答No.7

hananoppo

こんな感じでいかがでしょう。

Sub Sample()
Dim LastNum As Long
Dim Data() As String, aData As String
Dim rNum1 As Long, rNum2 As Long

Application.ScreenUpdating = False
Worksheets("最初").Activate
LastNum = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Data(2 To LastNum)
For rNum1 = 2 To LastNum
Data(rNum1) = Cells(rNum1, 1).Value & Cells(rNum1, 2).Value & Cells(rNum1, 3).Value
Next rNum1
Worksheets("残").Activate
For rNum2 = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
aData = Cells(rNum2, 1).Value & Cells(rNum2, 2).Value & Cells(rNum2, 3).Value
For rNum1 = 2 To LastNum
If Data(rNum1) = aData Then
Rows(rNum2).Delete
Data(rNum1) = Data(LastNum)
LastNum = LastNum - 1
Exit For
End If
Next rNum1
Next rNum2
Application.ScreenUpdating = True
End Sub

お礼

私のＶＬＯＯＫＵＰと同じ処理結果でかつ
1秒かかりませんでした。
20,000行でも挑戦してみます。
どうもありがとうございました。

補足

シート最初　10,046行
シート残　　11,425行
とデータが増えたら
約20秒と処理時間が長くなりました。

でも素晴らしいです。
どうもありがとうございました。

ただ記述にコメントを入れたいのですが
どの分が何をしているのか分からず
入れれないです。すいません。

回答No.6

layy

照合するキーがあるならエクセルに決めてかかる必要性はありません。アクセスでもＣＳＶファイルでも照合はできます。

１つのシートにて、合わせた14000行近くで最初と残の区別がつけばそれでも照合可能です。

決められた時間内にしなければいけないのか？、処理時間に不安げなのはよくわかりませんけど。

お礼

すいません。
エクセルがまだよく使えません。
アクセスは無理です。
処理時間についてですが自分で作成した
ＶＬＯＯＫＵＰは5分です。
よって20,000行だと15分かなと。
その間CPU使用率が100%で他の操作は出来ませんし
また以前ここでVLOOKUPを1秒以内にしてもらった事が
あるので出来るのかなと質問しました。
(ただしその時は値を返して転記で行削除ではなかったです。）
どうもありがとうございました。

回答No.5

merlionXX

条件により行を削除するのを、実際に削除するのではなく一旦配列に入れて早くする方法は
http://okwave.jp/qa/q6404265.html
でも、その前にもお見せしたと思いますが・・・・・・・・。

これでいかがですか？
実際に行を削除しているわけではないので、行により書式が違ったりすると変な感じになってしまいますが。

Sub test01()
　　Dim myS, myZ, myX
　　Dim i As Long, j As Long, n As Long, m As Long
　　Dim buf As Boolean
　　Dim zz As String, ss As String
　　With Sheets("最初")
　　　　myS = .Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
　　End With
　　With Sheets("残")
　　　　myZ = .Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
　　End With
　　ReDim myX(1 To UBound(myZ, 1), 1 To UBound(myZ, 2))
　　For i = 1 To UBound(myZ, 1)
　　　　buf = False
　　　　zz = ""
　　　　For j = 1 To UBound(myZ, 2)
　　　　　　zz = zz & myZ(i, j)
　　　　Next j
　　　　For n = 1 To UBound(myS, 1)
　　　　　　ss = ""
　　　　　　For j = 1 To UBound(myS, 2)
　　　　　　　　ss = ss & myS(n, j)
　　　　　　Next j
　　　　　　If zz = ss Then
　　　　　　　　buf = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next n
　　　　If Not buf Then
　　　　　　m = m + 1
　　　　　　For j = 1 To UBound(myZ, 2)
　　　　　　　　myX(m, j) = myZ(i, j)
　　　　　　Next j
　　　　End If
　　Next i
　　With Sheets("残")
　　　　.Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
　　　　.Range("A2").Resize(m, UBound(myZ, 2)).Value = myX
　　End With
End Sub

お礼

＞その前にもお見せしたと思いますが・・・・・・・・。

はい。それを改造すれば出来るとたかをくくっていましたが
駄目でした。

削除されるべき行が残ったり、
削除されてはいけない行が残ったり。
また両シートとも
Ａ～Ｅ列のデータなのですが
残った行において
途中までは正常ですが途中から
列のとこどころのデータが消失しました。
よってギブアップで質問しました。
その動かない私が改造した記述では
回答者様に解析の時間をとらせてしまうので
自分で出来た思ったとうりに動く
ＶＬＯＯＫＵＰの記述を載せました。

merlionXXさんに教えていただいた記述で試したのですが
すでにお断りがありますが

＞実際に行を削除しているわけではないので、
＞行により書式が違ったりすると変な感じになってしまいますが。

のとうり、
削除されるべき行が残ったり、
削除されてはいけない行が残ったり。
また両シートとも
Ａ～Ｅ列のデータなのですが
残った行において途中までは正常ですが
途中から列のとこどころのデータが消失しました。
よく分かりません。m(__)m

どうもありがとうございました。

補足

>削除されるべき行が残ったり、
>削除されてはいけない行が残ったり。
↓
削除されるべき行が残ったり、
削除されてはいけない行が削除されたりです。

またお礼に誤解を招く内容がありました。

私が別スレで教えていただいた物を改造した場合と
今回教えていただいた物の処理結果が
同じように読取れてしまいます。
そうではありませんでした。m(__)m

私の改造版の方が程度が悪いです。
merlionXXさんに今回教えていただいた方が
内容がはっきりしています。

まずシート（残）は1行も削除されておらず７，５６１行
そのまま残っています。
（１，３７９行だけ残る予定です。
　項目行を入れると１，３８０行目。）
Ａ～Ｅ列までデータがありますが
１３８０行目まではＡ～Ｅ列まで全部データがありますが
１３８１行目から７，５６１行までは
Ａ，Ｂ，Ｃ列の値がなくなりＤ，Ｅ列の値だけになっています。
処理時間は約１分です。
申し訳ありませんでした。

回答No.4

end-u

>記述そのものを教えてください。よろしくお願いします。
まずは記述そのものではなくて考え方から。
なのでニーズがない場合はスルーしてください。

・連結値用に固定の未使用列を使う。
　（例えば最右のIV列）
・１件ずつ重複チェックをするのではなく別作業列に数式を入れてまとめてチェックする。
　（例えばIU列に=ISNUMBER(MATCH(IV2,Sheet2!$IV$2:$IV$20000,0))などの数式
　　Formulaプロパティを使えばダイレクトに指定できるので解かりやすい）
・１行ずつ削除するのではなく並べ替えてまとめて削除する。
　（IU列基準にソートして下のほうにTRUEがまとまるのでこれを削除）

ワークシート上での作業ですから、複数範囲にまとめて数式を入れたりソートを活用したり。
シート上のソートは速くて便利です。
まずはVBAのA。Applicationの長所を活かして実務を行えば良いのではないでしょうか。

前述の処理は基本的に「マクロの記録」でベースが録れます。
自分で理解した上でコーディングできるので応用も利きやすく、
今後の役にも立つのではないでしょうか。

お礼

計算式を入れたのですが
処理が終わらずフリーズ状態になりました。
多分式の入れ方が悪いのだと思いますが
ちょっと手に負えませんでした。
どうもありがとうございました。

回答No.3

D-Matsu

A.SelectとSelection.Bを使わず、直接A.Bと書くことを意識するだけでもそこそこ速くなります。

これは、例えば以下のコードを
--
Sheets("残").Select
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
--

こう書きなおす、という事です。
--
Sheets("残").Columns("F:F").Delete Shift:=xlToLeft
--

Application.ScreenUpdating = falseは画面更新が完全に止まってしまいフリーズと見分けがつかなくなるので、最後の最後まではなるべく使わない方がいいと思います。確かにこれはよく効きますが。
あと、長時間かかる処理は適宜DoEventsを入れておくといいです。これは何らかのバグで無限ループに陥った時などにExcelを強制終了する必要がなくなるため。

お礼

教えていただいた
とうり試して見ましたが
あまり速くはなりませんでした。
どうもありがとうございました。

回答No.2

layy

どんなことが遅い要因か、意識したらいいでしょう。
セルを選択するのがあちこち行く。
シートを跨ぐ。
行削除等で表示内容が変わる。
等が遅くさせると思えば良いです。

マウスカーソルが転々と動けば動くほど遅い。

最近は性能のおかげで早いのでしょうが、ロジックや記載変えるだけで無駄が無くなりさらに早くなることもあります。

行削除はしないで、削除する行にマーキング。マーキングした行を並び替えかフィルタでまとめた後で複数行をクリア。これだけでも早くなりますし、ＮＯ１さんの対処も早くする手段ですから両方やる。

お礼

>削除する行にマーキング

この時にVLOOKUPを使いました。
マーキングしている処理の時に
時間がかかってあまり速くはなりませんでした。
どうもありがとうございました。

回答No.1

FEX2053

プログラムの先頭に

Application.ScreenUpdating = False

最後尾に

Application.ScreenUpdating = True

を入れて、処理中の画面更新を止めてみてはどうですか？

お礼

よく指摘を受ける内容なのに忘れてました。
入れてみましたが
処理時間はかわりませんでした。
VLOOKUPの処理が重いです。
（マクロでなくても式を入れても重いです。）
どうもありがとうございました。