重複列の検索で複雑な場合にやるvbaマクロ

Sub test5()
    t = Timer
    
    Dim A
    '辞書を作成
    Set A = CreateObject("Scripting.Dictionary")
    
    Dim B, C, D, E, TeikiID

    B = Range("O2:O121546") 'カウント元の値を取得
    D = Range("C2:C121547") 'カウント元の値を取得(日付) ※日付は重複を確認するために次行も選択してい
    E = Range("J2:J121547") 'カウント元の値を取得(処理CD)
    TeikiID = Range("A1:A121547") 'カウント元の値を取得(処理CD)
    
    '途中からカウントしたい場合はこのあたりいじってください 96267部分が行数です
    'B = Range("O96267:O121546") 'カウント元の値を取得
    'D = Range("C96267:C121547") 'カウント元の値を取得(日付) ※日付は重複を確認するために次行も選択してい
    'E = Range("J96267:J121547") 'カウント元の値を取得(処理CD)
    'TeikiID = Range("A96266:A121547") 'カウント元の値を取得(処理CD)
    
    Dim Totyuint As Variant
    '途中からカウントしたい場合はこのあたりいじってください
    Totyuint = 0
    
    
    'N列に中止、復活の重複を探すための値を入力
    'カウント元をループ
    For i = 1 To UBound(B, 1)
        Cells(i + Totyuint + 1, 15).Value = Str(Cells(i + Totyuint + 1, 2).Value) & ":" & Str(Cells(i + Totyuint + 1, 10).Value) & ":" & Str(Cells(i + Totyuint + 1, 12).Value)
    Next
    
    C = Range("O2:O121547") 'カウント先の値を取得
    
    'カウント元をループ
    For i = 1 To UBound(C, 1)
      If A.Exists(C(i, 1)) = False Then
        A.Add C(i, 1), 0 'カウント元を辞書に登録
        A.Add C(i, 1) + "day", D(i, 1) 'カウント元を辞書に登録
      Else
       '存在した場合、日付が新しい方を有効にする
        If D(i, 1) > A(C(i, 1) + "day") Then
             A(C(i, 1) + "day") = D(i, 1)
        End If
      
      End If
    Next
    
    

    
    'カウント先をループ
    For i = 1 To UBound(C, 1)
        '辞書に登録されている場合
        
        'Debug.Print C(i, 1)
        
        If A.Exists(C(i, 1)) Then
            A(C(i, 1)) = A(C(i, 1)) + 1 'カウントアップ
        End If
        
        'Debug.Print i
        'Debug.Print A(C(i, 1) + "day")
        'Debug.Print A(C(i, 1))

                
    Next
    
   'ここまでやってそれぞれの値の件数がわかった
   '件数がわかった辞書の結果をセルに入力させる
   
    For i = 1 To UBound(C, 1)
        
        '値が存在する場合にカウント数を入力する
        If A.Exists(C(i, 1)) Then
           'Debug.Print A.Item(C(i, 1))
            Cells(i + Totyuint + 1, 16).Value = A.Item(C(i, 1))
            
          
           'Debug.Print D(i, 1)
           'Debug.Print A.Item(C(i, 1) + "day")
           
           '新しい日付と一致する場合は、列に１を入力する,ただleftjoinで抽出してる都合上、次行に日付重複がありえるのでこちらもチェック対象にする
            
            '最新日と一致していてかつ次のカラムと同一の処理内容CDが一緒でない場合は書き込み対象
            If A.Item(C(i, 1) + "day") = D(i, 1) Then
            
                '重複code一致している該当重複codeの最終行を探す
                Dim saisyugyou As Variant
                saisyugyou = Saisyu(C(i, 1), t)
            
                'Debug.Print saisyugyou
                'Debug.Print i
            
                'If saisyugyou = 200 Then
                
                '    Debug.Print "チェック"
                
                'End If
            
                If saisyugyou = i + Totyuint + 1 Then
            
                    //比較
                    If E(i, 1) = 1 Then
                        Cells(i + Totyuint + 1, 18).Value = 1
                    Else
                        Cells(i + Totyuint + 1, 17).Value = 1
                    End If
                
                End If

            End If
            
            
            
            'Debug.Print C(i, 1)
        End If
        

        
        
    Next
   
    
    Debug.Print Timer - t & " 秒"
   
    
End Sub



Function Saisyu(FindStr, Timer)
    Dim i As Long
    
    If Len(FindStr) = 0 Then Exit Function
    
    'FindStr = "*" & FindStr & "*"   '部分一致検索
    FindStr = FindStr    '完全一致
    
    For i = Cells(Rows.Count, 15).End(xlUp).Row To 1 Step -1
    
        'Debug.Print i
        
        With Cells(i, 15)
            If .Value Like FindStr Then
                '.Activate
                
                'Debug.Print i
                
                If (i Mod 10) = 0 Then
                    Debug.Print "現在" & i
                    DoEvents
                End If
                
                
                Saisyu = i
                
                Exit For
            End If
        End With
        
        
    Next i
End Function