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

Question

シート（最初）の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

merlionXX · Accepted Answer

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

cj_mover · Answer

Re:No.15
> コンパイルエラー
...
> > ' ' Refer : "Microsoft Svripting Runtime"
ごめんなさい。m(__)mタイプミスです。

> で1秒かかりませんでした。凄く速いです。
速ければいいとは思っていませんし、もっと速いのもあります。

> 今回はこういうことはありません。
> （連結した為に重複値になってしまう）
えーと、存じておりましたです（ご質問はほぼすべて目を通しましたし）。
「今回は必要ない から 省略する」
のか、それとも
「想定外の変更にも備えて、少しでも手直しし易いように書いて おく」
のか、の違いですよね（害はない筈ですし）。

> ...流用ができません。...
> ...都度記述を書換えないと使えないので...
> ...データがある範囲は都度変化する...
ここがご質問のポイントだと解釈してヒントのつもりでお応えしたものなのですが、読み違えてましたか？

私も、ご自分で 理解された上で ご自分で自在に メンテ出来る ものを実装されるのがよいと思います。
だから、No.14さんへのレスを見て、少しほっとしました。
でも、１からすべて、とか、コードに全部コメント付けてっていうのは難しいかもしれませんよ。
余計なことかも知れませんが、私なりのアドバイスとして、
　ＶＢＡの作成依頼が殺到している現状を、上司にも相談して、改善して、
　可能なら、力量以上にExcelに依存しすぎているらしいシステムの見直しも検討してもらって、
　使用中のＶＢＡの記述にも理解を深めながら、同時にきちんとステップを踏みながら勉強して
　質問は、個別具体的なものを、ひとつずつ
にしていった方がよいと思います（わかりきったこと、かも知れませんが）。
今のやり方では身に付かない（残らない）のではないかと。
例えばですけど、たまには全体を俯瞰して、
　何にどれだけの時間を割いて、どれだけの出来高を取れるか、で、優先順位を決め直す
（↑私の場合）とか、何でもいいのですけど、少し打開策をお考えになった方がいいかも、です。

それから、質問タイトルでよく見かけるのですが、「高速化」は、
ＶＢＡを学ぶものにとって、結果であって目的や方法ではないと考えます。
遅さの解消、とか、最適化、とか、似て非なるものも沢山ありますし、
定義が曖昧な言葉はなるべく避けた方がより充実した質疑になるかと思います。

cj_mover · Answer

完全に蛇足のつもりで書きます。
私が提示したものは（私なりに狙いがあって書いたものですけれど）実装しない方が良いと思っています。
（一部、変わった書き方が混じってますし）
ユーザーが自力で手直しできないようなものを”提供”するのは、
開発者にとってもユーザーにとっても、面倒を先送りするようなものかも知れませんね。
質問者さんも、現実に提供（開発）する立場で、気づいたことがあるんじゃないかと思います。
少々速く処理できたって、手直しに時間掛けてたら結局、生産性低いですしね。

ただ、（リベンジって訳でもないのですが）ソート機能について、少しわかったことがあったので、
ソート版も一応ここに載せさせて下さい。
すべての列をソートする、と時間掛かるんですね。
（その方がわかりやすい＝高速化よりも大切、という意図で他の方は書かれていたのでしょうが）
必要な列数だけソートするように書いたら、原質問の条件では、配列出力より速かったです。
（高速化も条件次第の相対的なもの、という実証にもなりますが）
やっぱ、Excelの一般機能も侮れないですね。
勉強になりました。

Sub Re6461201evs()
Const S_SH1 = "最初", S_SH2 = "残"
Const S_FML = "TRANSPOSE(A1:A_&CHAR(13)&B1:B_&CHAR(13)&C1:C_)"
Dim arrConc, mtxPrt
Dim oDic As Object
Dim oRng As Range
Dim nR As Long, nC As Long
Dim i As Long, j As Long, c As Long

Application.EnableEvents = False
　With Sheets(S_SH1)
　　nR = .Cells(2, 1).CurrentRegion.Rows.Count
　　arrConc = .Evaluate(Replace$(S_FML, "_", CStr(nR)))
　End With

Set oDic = CreateObject("Scripting.Dictionary")
　For i = 2 To nR
　　oDic(arrConc(i)) = Empty
　Next i
　Erase arrConc

With Sheets(S_SH2)
　　Set oRng = .Cells(2, 1).CurrentRegion
　　nR = oRng.Rows.Count: nC = oRng.Columns.Count
　　arrConc = .Evaluate(Replace$(S_FML, "_", CStr(nR)))
　End With

ReDim mtxPrt(1 To nR, 0) As Boolean
　For i = 2 To nR
　　If oDic.Exists(arrConc(i)) Then
　　　c = c + 1
　　　mtxPrt(i, 0) = True
　　End If
　Next i
　Erase arrConc

If c > 0 Then
Application.ScreenUpdating = False
　　With oRng.Columns(nC + 1)
　　　.Value = mtxPrt
　　　oRng.Resize(, nC + 1).Sort Key1:=.Cells(2, 1), Order1:=xlDescending _
　　　　　, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
　　　　　, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
　　　.Clear
　　End With
　　Application.GoTo oRng.Rows("2:" & c + 1) ' ←確認用（確認後　当行削除）
'　　oRng.Rows("2:" & c + 1).Delete xlShiftUp ' ←実装用（確認後　当行先頭１文字 ' 削除）
　　mtxPrt = oRng.Worksheet.UsedRange.Count ' ダミー。UsedRange 更新
　End If

Exit_:
Application.EnableEvents = True
Application.ScreenUpdating = True
Set oDic = Nothing: Set oRng = Nothing
End Sub

end-u · Answer

re:#8
>参照可能なライブラリファイル
>で
>Microsoft Scripting Runtime
>というのは無かったのですが．．．．．
「参照可能なライブラリファイル」の中で
VBAProject..以降はアルファベット順で並んでますからよく確認してくださいね。
どうしてもダメだったら
>Dim dic As Dictionary
Dim dic As Object
：
>Set dic = New Dictionary
Set dic = CreateObject("scripting.dictionary")
で実行できますけど。

re:#10
>これだと
>9321020027008012345678は削除
>9321020027008012347777は残る
>が正解ですが
>双方削除されてしまいます。

>r1.Formula = "=A2&B2&C2"
r1.Formula = "=""'""&A2&B2&C2"
：
>r2.Formula = "=A2&B2&C2"
r2.Formula = "=""'""&A2&B2&C2"
修正して文字列扱いにしてください。

merlionXX · Answer

merlionXXです。
ANo13の補足についてです。

> 処理前と同じ状態でセルに色塗りされています。
> これは配列にとりこんで、書き出ししている為という解釈でよろしいでしょうか？

不要な行を削除したのに行の色は削除前の状態のままになってるということですか？
そういう意味ならその通りです。
この質問にかぎらずこれまで何度も言いましたが、実際に行を削除したわけではなく、データを配列に取り込み、必要な行だけ別の配列に転記して、データを消去したワークシートにデータを転記しただけですから。
これまでの質問どおり、元データが基幹システムが自動ではきだしたデータということだったので、セルの書式については考慮していません。
チェック作業を行ないたいなら、列を一つ増やしてそこにフラグをたてたらどうですか？

どうしても色でやりたいならANo14さんのように、並べ替えを使う方法がありますね。
あと、ANo15 cj_moverさんが懸念されてるような、A、B、C列を結合することによって本来異なるデータが結合すると同じデータになってしまう心配もないと以前の質問で確認していたのでそこも考慮していません。
どうも同じ質問者に何度も同じような回答を続けると以前の質問の条件に引きずられてあまりよくないことかもしれませんね。

cj_mover · Answer

お邪魔します。
ご無沙汰なので読み違いがあれば、ご容赦を。

連結に関して
　あ　いう　え
　あい　う　え
みたいな場合を（改行を区切りに使って）ケアしてます。
この点を重視しているので、Excel側に処理を依頼する形で書いてます。
抽出対象（A:C）が変更になる場合は、S_FMLのA1:A、B1:B、C1:C、を置換します。
列数はCurrentRegionに任せていますので、連続していれば問題ありません。
（その為にシート保護対策をいれました。）
本当は、バックアップ取ったり、エラー対策入れたり、で書いていたんですが、
5000文字超えたので諦めました。

Sub Re6461201eva()
' ' Refer : "Microsoft Svripting Runtime"
Const S_SH1 = "最初", S_SH2 = "残"
Const S_FML = "TRANSPOSE(A1:A#&CHAR(13)&B1:B#&CHAR(13)&C1:C#)"

Dim arrConc
Dim mtxSc
Dim mtxPrt
Dim oDic As Dictionary
Dim oRng As Range
Dim cntR As Long, cntC As Long
Dim i As Long, j As Long, cn As Long
　　　
With Application
　.ScreenUpdating = False
　.EnableEvents = False
End With

With Sheets(S_SH1)
　　If .ProtectContents Then
　　　If Not .ProtectionMode Then
　　　　.Protect DrawingObjects:=.ProtectDrawingObjects _
　　　　　, Contents:=True, Scenarios:=.ProtectScenarios, UserInterfaceOnly:=True
　　　End If
　　End If
　　With .Cells(2, 1).CurrentRegion
　　　cntR = .Rows.Count
　　End With
　　arrConc = .Evaluate(Replace$(S_FML, "#", CStr(cntR)))
　End With
　Set oDic = New Dictionary
　For i = 2 To cntR
　　oDic(arrConc(i)) = Empty
　Next i
　
　With Sheets(S_SH2)
　　If .ProtectContents Then
　　　If Not .ProtectionMode Then
　　　　.Protect DrawingObjects:=.ProtectDrawingObjects _
　　　　　, Contents:=True, Scenarios:=.ProtectScenarios, UserInterfaceOnly:=True
　　　End If
　　End If
　　Set oRng = .Cells(2, 1).CurrentRegion
　　mtxSc = oRng.Value
　　cntR = UBound(mtxSc): cntC = UBound(mtxSc, 2)
　　arrConc = .Evaluate(Replace$(S_FML, "#", CStr(cntR)))
　End With

ReDim mtxPrt(1 To cntR, 1 To cntC)
　For i = 1 To cntR
　　If Not oDic.Exists(arrConc(i)) Then
　　　cn = cn + 1
　　　For j = 1 To cntC
　　　　mtxPrt(cn, j) = mtxSc(i, j)
　　　Next j
　　End If
　Next i

With oRng
　　.Value = Empty
　　.Value = mtxPrt
　　Erase mtxPrt
　　.Rows(cn + 1 & ":" & cntR).Clear ' ←書式などをクリアしたい場合
　　cn = .Worksheet.UsedRange.Count ' ダミー。UsedRange 更新
　End With

With Application
　.EnableEvents = True
　.ScreenUpdating = True
End With
　Set oDic = Nothing: Set oRng = Nothing
End Sub

hananoppo · Answer

ANo.7です。20秒もかかっちゃいましたか。それならこれでいかがでしょう。

Sub Sample()
    Dim StartTime As Single
    Dim LastNum1 As Long, LastNum2 As Long, LastNum3 As Long
    Dim Data() As String, aData As String
    Dim rNum1 As Long, rNum2 As Long
    Dim Unique As Boolean

StartTime = Timer
    Application.ScreenUpdating = False
    Worksheets("最初").Activate
    LastNum1 = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim Data(2 To LastNum1)
    For rNum1 = 2 To LastNum1
        Data(rNum1) = Cells(rNum1, 1).Value & Cells(rNum1, 2).Value & Cells(rNum1, 3).Value
    Next rNum1
    Worksheets("残").Activate
    LastNum2 = Cells(Rows.Count, 1).End(xlUp).Row
    For rNum2 = LastNum2 To 2 Step -1
        aData = Cells(rNum2, 1).Value & Cells(rNum2, 2).Value & Cells(rNum2, 3).Value
        Unique = True
        For rNum1 = LastNum1 To 2 Step -1
            If Data(rNum1) = aData Then
                Data(rNum1) = Data(LastNum1)
                LastNum1 = LastNum1 - 1
                Unique = False
                Exit For
            End If
        Next rNum1
        If Unique Then Cells(rNum2, 256).Value = True
    Next rNum2
    Cells.Sort Key1:=Cells(1, 256), Header:=xlYes
    LastNum3 = Cells(Rows.Count, 256).End(xlUp).Row
    If LastNum3 < LastNum2 Then Rows(LastNum3 + 1 & ":" & LastNum2).ClearContents
    Columns(256).ClearContents
    Application.ScreenUpdating = True
    MsgBox Timer - StartTime & "秒"
End Sub

行削除は時間を食うようなので、並べ替えとデータクリアで対処しました。

merlionXX · Answer

> シート（最初）とシート（残）の列数が相違する場面が出てきます。
> 配列に取り込む以上、都度書き換えするしかないという解釈でよろしいのでしょうか？

これまでも言ったとは思うけど、わたしはgx9wxちゃんのPCは見れないよ～。
だからデータがどんな状態なのかわからない。
(￣～￣;)う～ん　　
たとえば、必ず1行目がタイトル行で、A列から最後の列まで全部タイトルが空白無く入っているとか、何列あるのかの確認できる方法があるのかないのか、そちらが指定してくれなきゃわかりません。

となると都度書き換えするようなコードしか回答できないんです。
それでも今回のは列記号の指定ぐらいで済むように書いたつもりだけどね。
（￣ー￣）v

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

ピンポ～ン！
その証拠にSheets("最初")で
myS = .Range("A2:AC" & .Cells(Rows.Count, "A").End(xlUp).Row).Valueって間違って列を指定したけど正しく動いてる。
言うまでも無く、myS = .Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value　が正しい。（直しておいてください。）
(///▽///)

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

そうですよ。

> で今回はＡ～Ｅ列ですが例えばＡ～Ｇ列の場合
中略
> の２ケ所の変更だけでよろしいのでしょうか？

そのはずです。

あと、
    Dim t As Single
    t = Timer
　　Debug.Print Timer - t
の3行は、こちらで実行速度を調べた残骸（消すのを忘れた）だから不要なら消してください。
自分でも調べるなら、VBE画面でCtrl+Gでイミディエイトウィンドを表示させてください。

merlionXX · Answer

merlionXXです。
データはA~E列まであって、そのうちA~Cを結合した値が一致したものをSheets("残")から消せばいいんですね？
順列組み合わせなのでたいして早くはないでしょうが、いまちょっとたてこんでいるのでとりあえずここまで。

Sub testA_E列()
　　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("最初") 'A_C列を配列mySに
　　　　myS = .Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
　　End With
　　With Sheets("残") 'A_E列を配列myZに
　　　　myZ = .Range("A2:AE" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
　　End With
　　ReDim myX(1 To UBound(myZ, 1), 1 To UBound(myZ, 2)) As String '配列myX用意
　　For i = 1 To UBound(myZ, 1)
　　　　buf = False
　　　　zz = ""
　　　　For j = 1 To 3 'ABC列文字結合
　　　　　　zz = zz & myZ(i, j)
　　　　Next j
　　　　For n = 1 To UBound(myS, 1)
　　　　　　ss = ""
　　　　　　For j = 1 To 3 'ABC列文字結合
　　　　　　　　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) '配列myXに格納
　　　　　　Next j
　　　　End If
　　Next i
　　Application.ScreenUpdating = False
　　With Sheets("残")
　　　　.Range("A2:AE" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
　　　　.Range("A2").Resize(m, UBound(myZ, 2)).Value = myX
　　End With
　　Application.ScreenUpdating = True
End Sub

end-u · Answer

とりあえず、数式版リベンジ :D
MATCH関数の照合の型0じゃなく、照合先を昇順ソートして照合の型を1にします。
例えば
=IV2=INDEX(Sheet2!$IV$2:$IV$30000,MATCH(IV2,Sheet2!$IV$2:$IV$30000,1))
こんな式。

Sub try_2()
　　Dim r1 As Range　'照合元（残）
　　Dim r2 As Range　'照合先（最初）
　　Dim r　As Range　'削除起点
　　Dim s　As String '数式用

'データ範囲の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"
　　r1.Value = r1.Value
　　r2.Formula = "=A2&B2&C2"
　　r2.Value = r2.Value
　　'数式用のアドレス取得
　　s = r2.Address(external:=True)
　　'作業列をIU列に変更
　　Set r2 = r2.Offset(, -1)
　　'元データの並びを記録
　　r2.Formula = "=row()"
　　r2.Value = r2.Value
　　'IV列昇順にソート（数式の為に必要）
　　r2.EntireRow.Sort Key1:=r2.Item(1).Offset(, 1), _
　　　　　　　　　　　Order1:=xlAscending, _
　　　　　　　　　　　Header:=xlNo, _
　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　Orientation:=xlTopToBottom
　　'作業列をIU列に変更
　　Set r1 = r1.Offset(, -1)
　　'数式セット
　　r1.Formula = "=IV2=INDEX(" & s & ",MATCH(IV2," & s & ",1))"
　　r1.Value = r1.Value
　　'数式結果置換
　　r1.Replace "#N/A", "FALSE", xlWhole
　　'データ範囲のみソート
　　r1.EntireRow.Sort Key1:=r1.Item(1), _
　　　　　　　　　　　Order1:=xlAscending, _
　　　　　　　　　　　Header:=xlNo, _
　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　Orientation:=xlTopToBottom
　　'重複データの先頭を検索
　　Set r = r1.Find("TRUE", , xlValues, xlWhole)
　　If Not r Is Nothing Then
　　　　'重複データあれば行全体削除
　　　　Range(r, r1(r1.Count)).EntireRow.Delete
　　End If
　　'元データの並びにソートし直し
　　r2.EntireRow.Sort Key1:=r2.Item(1), _
　　　　　　　　　　　Order1:=xlAscending, _
　　　　　　　　　　　Header:=xlNo, _
　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　Orientation:=xlTopToBottom
　　'作業列削除
　　r1.EntireRow.Columns("IU:IV").Delete
　　r2.EntireRow.Columns("IU:IV").Delete

Set r = Nothing
　　Set r1 = Nothing
　　Set r2 = Nothing
End Sub
30,000×30,000で10secかかりませんので一応、許容範囲かな、と。

#提示コードの検証は慎重に。

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

merlionXXです。

Re:No.15

完全に蛇足のつもりで書きます。

re:#8

merlionXXです。

お邪魔します。

この回答への補足

ANo.7です。

この回答への補足

> シート（最初）とシート（残）の列数が相違する場面が出てきます。

この回答への補足

merlionXXです。

とりあえず、数式版リベンジ :D

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング