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

質問

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

cj_mover

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

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

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

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

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

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

お礼

>ごめんなさい。m(__)mタイプミスです。

いえ。ありがとうございます。

>「今回は必要ない から 省略する」
>のか、それとも
>「想定外の変更にも備えて、少しでも手直しし易いように書いて おく」
>のか、の違いですよね（害はない筈ですし）。

おっしゃるとおりです。

>でも、１からすべて、とか、コードに全部コメント付けてって
>いうのは難しいかもしれませんよ。

申し訳ありません。あつかましいお願いですね。反省します。

>私も、ご自分で 理解された上で ご自分で自在に
>メンテ出来る ものを実装されるのがよいと思います。

質問して、教えていただいて、そのまま実装して
はい終わりはちょっと出来ない性格でして、
教えていただいた物に分かる範囲で１行づつコメント入れてます。
また疑問に思ったら記述をわざと変えてどうなるか試したり。
一度教えていただいた物を改造して他に使ったりしてます。
でも．．．．．．．なんですよね。(T_T)

>それから、質問タイトルでよく見かけるのですが、「高速化」は、

申し訳ありません。
今回は自分の記述ではおそらく２０分はかかる。
最悪処理中にフリーズする可能性があると思い、
以前別スレで他の方に教えていただいた物を改造してのぞみましたが
完成できませんでした。

遅い記述を載せて速く処理したいと質問するか、
改造して処理が速いはずだが未完成の記述を載せて質問するか
迷いました。

>上司にも相談して

ごめんなさい。m(__)m

>今のやり方では身に付かない（残らない）のではないかと。

すいません。おっしゃるとうり残っていません。
残るわけが無いのも承知してます。
本当にすいません。m(__)m

>力量以上にExcelに依存しすぎているらしいシステム

システム変更．．．．．
リーマンショックさえなければ．．．．

>少し打開策をお考えになった方がいいかも

ごめんなさい。m(__)m

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

回答No.18

cj_mover

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

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

お礼

Application.GoTo oRng.Rows("2:" & c + 1) ' ←確認用（確認後　当行削除）
↓
これは削除でよろしいのでしょうか？

'oRng.Rows("2:" & c + 1).Delete xlShiftUp ' ←実装用（確認後　当行先頭１文字 ' 削除）
↓
これは'をはずせばよろしいのでしょうか？

そのままだと行削除されませんでしたので
上記のようにしましたら思ったとうりに動きました。

凄く速かったです。

>質問者さんも、現実に提供（開発）する立場で、
>気づいたことがあるんじゃないかと思います。

はい。あります。
ここで質問して教えていただいて、
質問したとうり動いて、でも
意地悪テストしていると、質問に不足が有った事に
気がつき追加質問になって．．．．．
あっ。それから私は開発者ではないです。
質問して教えていただいて実装してテストして
渡すだけです。m(__)m

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

回答No.17

end-u

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"
修正して文字列扱いにしてください。

お礼

＃８
>VBAProject..以降はアルファベット順で並んでますから
>よく確認してくださいね。

ありました。すいません。
思ったとおり動きました。
速度は２秒くらいでした。

＃１０
>r1.Formula = "=A2&B2&C2"
r1.Formula = "=""'""&A2&B2&C2"
：
>r2.Formula = "=A2&B2&C2"
r2.Formula = "=""'""&A2&B2&C2"

で正しく動きました。
こちらはおっしゃるとうり７秒程度かかりました。

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

回答No.16

merlionXX

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

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

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

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

お礼

>この質問にかぎらずこれまで何度も言いましたが、
>実際に行を削除したわけではなく、データを配列に取り込み、
>必要な行だけ別の配列に転記して、
>データを消去したワークシートにデータを転記しただけですから。

はい。何度も聞きました。m(__)m
確認をしたかったのですいません。

>チェック作業を行ないたいなら、
>列を一つ増やしてそこにフラグをたてたらどうですか？
>どうしても色でやりたいなら

チェック作業も盛り込みたいのではないです。
チェック作業は私の責任ですから大丈夫です。
申し訳ありません。

>以前の質問で確認していたのでそこも考慮

はい。大丈夫です。すいません。

>同じ質問者に何度も同じような回答を続けると
>以前の質問の条件に引きずられてあまりよくないことかもしれませんね

たまに「続き質問はマナー違反です」と指摘されます。
続き質問の場合は別スレにするように
しているつもりですが、別スレにしてかえって
伝えにくい場合もあります。
merlionXXさんにはつい、甘えてしまいます。
以後気をつけます。大変申し訳ありませんでした。
（でも守れないかもしれません．．．．．．．）
（ただこれを読む前に別スレで再質問してしまいました。
　ごめんなさい。）

回答No.15

cj_mover

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

連結に関して
　あ　いう　え
　あい　う　え
みたいな場合を（改行を区切りに使って）ケアしてます。
この点を重視しているので、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

お礼

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

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

Dim oDic As Dictionaryでとまります。

私の技量では分かりません。
申し訳ありません。

補足

大変失礼いたしました。
回答Ａ－ＮＯ．８で教えていただいた物を対応したら
思ったとおり動きました。

' ' Refer : "Microsoft Svripting Runtime"
↓
' ' Refer : "Microsoft Sｃripting Runtime"
でいいのですよね。
シート残15,289行
シート最初13,910行
で1秒かかりませんでした。凄く速いです。

＞抽出対象（A:C）が変更になる場合

これも対応していただき感謝です。
流用時に助かります。

＞連結に関して
＞　あ　いう　え
＞　あい　う　え
＞みたいな場合を（改行を区切りに使って）ケアしてます。
＞この点を重視しているので

説明不足ですいません。
お手数をかけてしまいました。

今回はこういうことはありません。
（連結した為に重複値になってしまう）
A列は10文字か14文字のみ。
B,C列は4文字固定長、空白はなし
です。

回答No.14

hananoppo

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

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

お礼

シート（最初）13,910行
シート(残）15,289行
9.964844秒でした。
ありがとうございました。

補足

すいません。教えてください。
私が大変お世話になっているmerlionXXさん
の回答ANO.12なのですが、
これは私もおぼろげに何をしているのか
わかるのですが配列に取り込んでいます。？
現在検証の為ダミーデータなのでセルに色を塗ったり
文字を赤くしたりしています。
配列に取り込んでその後書き出ししているので
処理結果ではこのセルの色塗りや赤文字は
引き継がれません。（実用上何も問題がありませんが）

hananoppoさんに教えていただいた物は
処理結果にて全部拭きつがれています。
お手数をかけて申し訳ありません。
記述の部分で大まかでかまいませので
どの分が何をしているのか
教えていただく事は出来ますでしょうか？
配列に取り込まず（取り込んでいるのかな？）
なぜこの速度で処理できるのかと
全然わかっていません。
お時間あったらでかまいません。
お願いします。

回答No.13

merlionXX

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

これまでも言ったとは思うけど、わたしは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でイミディエイトウィンドを表示させてください。

お礼

>myS = .Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value　
>が正しい。（直しておいてください。）

はい。直しました。

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

補足

すいません。お手数かけます。教えてください。

現在、検証の為、
セルに色を塗ったり
文字を赤くしたりしています。
シート（残）に残る1,379のレコードは
セルを黄色くしてあります。
処理が終了すると
項目行を含めて1,380行が残ります。
配列取り込みを使用しない処理だと
処理結果1,380行にて2～1,380行までセルは黄色です。

例えば
2～3行目はセルが白色
4行目はセルが黄色
5行目はセルが白色
6行目はセルが黄色
7行目はセルが黄色

4,6,7行目がシート（残）に残るべきレコードです。

処理後は抽出後なので
処理前4行目のレコードは処理後2行目、
処理前6行目のレコードは処理後3行目
処理前7行目のレコードは処理後4行目になっています。
ですがセルの色は
2行目は黄色のままで
3行目は白色のままで
4行目は黄色のままと
処理前と同じ状態でセルに色塗りされています。
これは配列にとりこんで、書き出ししている為
という解釈でよろしいでしょうか？

回答No.11

merlionXX

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

お礼

お手数かけています。
最速版を回答していただいたようなので
そちらで試します。
すいません。
ありがとうございます。

回答No.10

end-u

とりあえず、数式版リベンジ :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かかりませんので一応、許容範囲かな、と。

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

お礼

わざわざ、ありがとうございます。
残るべきデータの中で１０行だけ削除されます。
なぜ１０行だけが削除されるのか分かりません。

A列　英数字で10～14桁
B列　数字4桁
C列　数字4桁
と決まっています。

A列はほとんど英数字混在ですが
数字だけの場合も存在します。
A列が数字だけの場合が抽出できないようです。
（私の勝手な推測です。）

例えば
A列：93210200270080
B列：1234
C列：5678

このパターンで
シート残
9321020027008012345678
9321020027008012347777
シート最初
9321020027008012345678

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

このパターンが10行削除されているみたいです。
どうもありがとうございました。

回答No.9

rukuku

こんばんは

実際のデータでのスピードの検証はしていないのですが
Couontif関数
が使えるかもしれません。

シート（最初）とシート（残）のZ列にそれぞれ
ABCを連結した値を入れておきます。

シート（残）のAA2に
=COUNTIF(最初!Z:Z,残!Z2)
以下オートフィル
としますと、シート（最初）と重複なしなら0、あれば1以上となります。

オートフィルタを使用すれば、０の行を抽出できますので、別のシートやブックに抽出結果をコピー＆ペーストします。

お礼

マクロ作成以前はこの方法をマニュアルで行っていました。
・シート（最初）と重複なしなら0、あれば1
　が精度が悪く漏れがある
・計算式を入れて値が出たら
　値貼付で式を消さないと、シート最初→シート残に
　動かすと「再計算」でしばらくとまる
・同じく計算式で出た列の値優先で並び変えて
　１の行だけを一気に削除の時、
　「再計算」となる

などで使用者から
「値貼付って意味わからないし他の編集作業のように
　ボタン1個クリックでできるようにしてほしい」
と言われてマクロにしました。

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

補足

これは基幹システムが自動ではきだしたデータです。
でセルの書式設定は全て標準です。

B,C列は必ず数字4ケタです。
ただし「数値が文字列として保存されています」
となっています。
A列は英数字混在で10桁～14桁です。
で数字のみの場合も有り、
同じく「数値が文字列として保存されています」となっています。

このA列が数字のみで「数値が文字列として保存されています」と
なっていると、
=COUNTIF(最初!Z:Z,残!Z2)
以下オートフィルで、
シート（最初）と重複なしなら0、あれば1以上が
重複なのに0になってしまい漏れてしまいます。

また
シート最初が10,046行
シートが11,425行だと
=COUNTIF(最初!Z:Z,残!Z2)
以下オートフィル
した時にCPU使用率１００％でしばらくＰＣが
はまってしまいました。
どうもありがとうございました。