エクセルVBA どうしても処理が重いのを改善したい

質問

下記のコードを作りましたが、どうしても処理が２分を越えてしまいます。
書き方が下手なのか。。。修正案があればぜひともご教授願います。
行っている事は。。。
１．上から順番に最後の文字が入っている所まで検索をする。
２．１の際A2とA3セル内容を取得する。（この際にA２セルに入っているドメイン取得している）この取得した値を検索元のデータとしている。
３．２にて取得したデータを元に、検索対象セルの次行から一致する値を検索する。
４．ヒットしたら、ヒットした値がある行のE列に「１」を代入
５．全ての処理が終了したら、E列に「１」がある行全て削除
６．フィルター解除

Sub 案件抽出の重複削除()
Debug.Print Time & " - 案件抽出の重複削除スタート"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim s As String '// 検索元データ
Dim i As Long
Dim SI As String '// 検索元データの結合データ
Dim TD As String
Dim SS As String
Dim II As Long
Dim AJS As Range '// 検索元データのステートメント
Dim CAJS As Range '// 検索されるデータのステートメント
On Error Resume Next

For Each AJS In Range("A2:A" & Cells(100000, 1).End(xlUp).Row)
s = Cells(AJS.Row, 2)
i = InStrRev(s, "@") + 1
SI = Mid(s, i, Len(s) - i) & Cells(AJS.Row, 3)

For Each CAJS In Range(Cells(AJS.Row + 1, 2), Cells(Rows.Count, 1).End(xlUp))
If Cells(CAJS.Row, 5) = "" Then
SS = Cells(CAJS.Row, 2)
II = InStrRev(SS, "@") + 1
TD = Mid(SS, II, Len(SS) - i) & Cells(CAJS.Row, 3)

If SI = TD Then
Cells(CAJS.Row, 5) = 1
End If
TD = ""
End If
Next
Next

ActiveSheet.Range("$A$1:$E$2564").AutoFilter Field:=5, Criteria1:="1"
Rows(2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.End(xlUp).Select
ActiveSheet.AutoFilterMode = False

Debug.Print Time & " - 案件抽出の重複削除終了"

End Sub

宜しくお願い致します。

回答No.1

mt2015 · ベストアンサー

作り直すにあたって確認です。

1.コードを見るとB2とC2セルの内容を取得しています。質問文の方が間違えているという認識で良いですか？
2.B2セルに入っている@以降の文字列(ドメイン？）の最後の文字を捨てていますがこれは正しい動きですか？
　例：B2セルが「aaa@XYZ」、C2セルが「qwerty」の時、「XYqwerty」と言う文字列を内部で作成している
3.コードが間違えているように思うので確認してください
　現在：TD = Mid(SS, II, Len(SS) - i) & Cells(CAJS.Row, 3)
　正解？：TD = Mid(SS, II, Len(SS) - II) & Cells(CAJS.Row, 3)

補足

ご指摘の通り、質問文が間違えておりました。
また、ミスも分かり助かりました。

で、何故か処理が一気に２０秒程で終わる様になりまして
何故かは不明ですが、メモリの問題だったのかもしれません。

よって、今回のご質問は閉じさせて頂きます。

ご回答ありがとうございました！

回答No.2

nan93850673

こういった場合、私なら疑わしい場所へ、例えば
Debug.Print "処理名 " & now()
というのを挿入して、時間が掛かっている処理を特定します。

どうすれば早くなるか考えるのは、その後の話。