Ошибка Run time error ‘-2147417848 (80010108)’

Sub FindDub()
Range("Y:Y").Clear
Application.ScreenUpdating = False
StartCell = ActiveCell.Row
lastcell = Cells(Rows.Count, 3).End(xlUp).Row
Delta = 1
ColDub = 25
For a = 1 To StartCell - 1
  If Cells(a, 3).Value <> "" And Cells(a, ColDub).Value <> 1 Then
    For b = StartCell To lastcell
      If b <> a Then
         If UCase(Cells(a, 3).Value) = UCase(Cells(b, 3).Value) Then
          Range("A" & a & ":" & "Z" & a).Select
          Selection.Cut
          Range("A" & (lastcell + Delta) & ":" & "Z" & (lastcell + Delta)).Select
          ActiveSheet.Paste
          Delta = Delta + 1
          Cells(b, ColDub).Value = 1
         End If
      End If
    Next
  End If
  Next
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    For r = LastRow To 1 Step -1
    If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
Application.ScreenUpdating = True
End Sub

Sub asdfsdf()
   Dim j&, mstr$, mRNG As Range, cC As Range
j = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
mstr = Application.InputBox(" Select cell with your word", , , , , , , 8).Value
   With ActiveSheet
      .Range("a3").AutoFilter Field:=3, Criteria1:=mstr
      Set mRNG = Range(Cells(2, 1), Cells(j, 1)).SpecialCells(xlCellTypeVisible)
      .Range("a3").AutoFilter
         For Each cC In mRNG
            cC.Rows.EntireRow.Copy .Cells(Rows.Count, "a").End(xlUp).Offset(1, 0)
         Next cC
   End With
End Sub

Sub asdfsdf()
   Dim i&, j&, k&, mRNG As Range, cC As Range, marr(), arrRow()
   Application.ScreenUpdating = False
   j = Cells(Rows.Count, "a").End(xlUp).Row
   marr = Range(Cells(j + 1, "c"), Cells(Rows.Count, "c").End(xlUp)).Value
      With ActiveSheet
         For i = LBound(marr, 1) To UBound(marr, 1)
            .Range("a3").AutoFilter Field:=3, Criteria1:=marr(i, 1)
            Set mRNG = Range(Cells(2, 1), Cells(j, 1)).SpecialCells(xlCellTypeVisible)
            ReDim arrRow(1 To mRNG.Cells.Count):   k = 1
               For Each cC In mRNG
                  arrRow(k) = cC.Row: k = k + 1
               Next 'cC
            .Range("a3").AutoFilter
            mRNG.Cells(1).Rows.EntireRow.Copy .Cells(Rows.Count, "c").End(xlUp).Offset(1, -2)
               For k = UBound(arrRow) To LBound(arrRow) Step -1
                  Rows(arrRow(k)).Delete:  j = j - 1
               Next 'k
         Next 'i
         Erase arrRow: Set mRNG = Nothing
         For i = UBound(marr, 1) To 1 Step -1
            .Rows(j + UBound(marr, 1)).ClearContents: j = j - 1
         Next 'i
      End With
      Application.ScreenUpdating = True
      Erase marr:   MsgBox Space(10) & "D O N E!"
End Sub

mRNG.EntireRow.Delete

Sub v2_my60000()
Dim i&, j&, mrng As Range, marr(), sttime!
    sttime = Timer
    Application.ScreenUpdating = False
      j = Cells(Rows.Count, "a").End(xlUp).Row
      If j + 1 <> Cells(Rows.Count, "c").End(xlUp).Row Then
         For i = Cells(Rows.Count, "c").End(xlUp).Row To j Step -1
            If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete
         Next 'i
         marr = Range(Cells(j + 1, "c"), Cells(Rows.Count, "c").End(xlUp)).Value
            Else
               ReDim marr(1 To 1, 1 To 1): marr(1, 1) = Cells(j + 1, "c").Value
      End If
   With ActiveSheet
      If .Cells.AutoFilterMode Then .Cells.AutoFilter
      For i = LBound(marr, 1) To UBound(marr, 1)
            .Range("a3").AutoFilter Field:=3, Criteria1:=marr(i, 1)
            Set mrng = Range(.Cells(2, 1), .Cells(j, 1)).SpecialCells(xlCellTypeVisible)
            Select Case mrng.Cells.Count
                Case Is < 2: MsgBox "Not found dublicate for " & marr(i)
                Case Is > 1
                    .Range("a3").AutoFilter
                    mrng.Cells(1).Rows.EntireRow.Copy .Cells(Rows.Count, "c").End(xlUp).Offset(1, -2)
                    j = j - mrng.Cells.Count
                    mrng.EntireRow.Delete
            End Select
        Next 'i
        Set mrng = Nothing
        For i = UBound(marr, 1) To 1 Step -1
            .Rows(j + UBound(marr, 1)).ClearContents: j = j - 1
        Next 'i
    End With
    Application.ScreenUpdating = True
    MsgBox ("Time:   " & Format(Timer - sttime, "#,##0.00"))
    Erase marr: MsgBox (Space(10) & "D O N E!")
End Sub

Sub delDUBLICATE_60000()
   Dim mrng As Range, i&, j&, n&, k&, marr(), sttime!
   Application.ScreenUpdating = False
   sttime = Timer
   With ActiveSheet
      If .AutoFilterMode = True Then .AutoFilterMode = False
      n = .UsedRange.Column - 1 + .UsedRange.Columns.Count
      Set mrng = Range(.Cells(3, 1), .Cells(.UsedRange.Row - 1 + .UsedRange.Rows.Count, n))
      ReDim marr(0 To n - 1):    j = 0
         For i = 1 To n:      marr(j) = i:   j = j + 1:   Next 'i
      mrng.RemoveDuplicates (marr), xlNo
'--End--Part1----------------------------------------------------
      j = Cells(Rows.Count, "a").End(xlUp).Row
         If j + 1 <> Cells(Rows.Count, "c").End(xlUp).Row Then
            For i = Cells(Rows.Count, "c").End(xlUp).Row To j Step -1
               If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete
            Next 'i
            marr = Range(Cells(j + 1, "c"), Cells(Rows.Count, "c").End(xlUp)).Value
               Else
                  ReDim marr(1 To 1, 1 To 1): marr(1, 1) = Cells(j + 1, "c").Value
         End If
         j = .Cells(.Rows.Count, "c").End(xlUp).Row:   k = j - UBound(marr, 1)
         For i = LBound(marr, 1) To UBound(marr, 1)
            .Range(Cells(2, 1), Cells(k, n)).AutoFilter Field:=3, Criteria1:=marr(i, 1)
            On Error Resume Next: Err.Number = 0
            Set mrng = Range(.Cells(3, 1), .Cells(k, n)).SpecialCells(xlCellTypeVisible)
               Select Case Err.Number
                  Case Is <> 0: MsgBox "Not found criteria   " & marr(i, 1): .AutoFilterMode = False
                  Case Is = 0
                     mrng.Rows.Copy .Cells(j + 1, 1): .AutoFilterMode = False
                     j = .Cells(.Rows.Count, "c").End(xlUp).Row
               End Select
         Next 'i
   End With
   Application.ScreenUpdating = True: ActiveWindow.ScrollRow = j
   Erase marr:  Set mrng = Nothing: MsgBox "My TIME:" & Space(3) & Format(Timer - sttime, "#0.00000")
End Sub

Sub vDICT_delDUBLICATE_60000()
   Dim mrng As Range, i&, j&, n&, k&, marr(), stTime!, cC As Range
   Dim dict As Object, elt, colEL, inELT
   Application.ScreenUpdating = False
   stTime = Timer
'   --Remove--All--DUBLICATE--------------------
   If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
   With ActiveSheet
      n = .UsedRange.Column - 1 + .UsedRange.Columns.Count
      Set mrng = Range(.Cells(3, 1), .Cells(.UsedRange.Row - 1 + .UsedRange.Rows.Count, n))
      ReDim marr(0 To n - 1):    j = 0
         For i = 1 To n:      marr(j) = i:   j = j + 1:   Next 'i
      mrng.RemoveDuplicates (marr), xlNo
      j = .Cells(Rows.Count, "c").End(xlUp).Row
         With Range(.Cells(j + 1, 1), .Cells(Rows.Count, Columns.Count))
            .ClearComments: .Interior.ColorIndex = xlNone
         End With
'==End==REMOVE==============================
      k = .Cells(Rows.Count, "a").End(xlUp).Row
         If j - k > 1 Then
            For i = j To k + 1 Step -1
               If Application.CountA(.Rows(i)) = 0 Then .Rows(i).Delete: j = j - 1
            Next 'i
         End If
      Select Case j - k
         Case Is = 0: MsgBox "My TIME:" & Space(3) & _
                  Format(Timer - stTime, "#0.00000") & Chr(13) & Chr(13) & _
                        "THE   CRITERIAS   ARE   NOT SPECIFIED."
            ActiveWindow.ScrollRow = j:    Exit Sub
         Case Is = 1:  ReDim marr(1 To 1, 1 To 1): marr(1, 1) = LCase(Application.Trim(.Cells(j, "c").Value))
         Case Is > 1
            marr = Range(.Cells(j, "c"), .Cells(k + 1, "c")).Value
      End Select
      Set dict = CreateObject("scripting.dictionary")
      dict.comparemode = 1
         For i = LBound(marr, 1) To UBound(marr, 1)
            If Not dict.exists(marr(i, 1)) Then dict.Add marr(i, 1), New Collection
         Next 'i
         Erase marr
         For Each cC In Range("c3:c" & k)
            If dict.exists(LCase(Application.Trim(cC.Value))) Then
               With dict.Item(LCase(Application.Trim(cC.Value)))
                  .Add Range(.Cells(cC.Row, 1), .Cells(cC.Row, n))
               End With
            End If
         Next 'cC
         For Each elt In dict.keys
            Set colEL = dict.Item(elt)
               For Each inELT In colEL
                  inELT.Copy .Cells(.Rows.Count, "c").End(xlUp).Offset(1, -2)
               Next
         Next
   End With
   Set mrng = Nothing:  Application.ScreenUpdating = True:  ActiveWindow.ScrollRow = j
   set dict=Nothing:  MsgBox "My TIME:" & Space(3) & Format(Timer - stTime, "#0.00000")
End Sub

'   --Remove--All--DUBLICATE--------------------
   With ActiveSheet
      n = .UsedRange.Column - 1 + .UsedRange.Columns.Count
      Set mRng = Range(.Cells(3, 1), .Cells(.Cells(Rows.Count, "a").End(xlUp).Row, n))
      ReDim mARR(0 To n - 1):   For i = 1 To n:     mARR(i - 1) = i:   Next 'i
      mRng.RemoveDuplicates (3), xlNo
      j = .Cells(Rows.Count, "c").End(xlUp).Row
         With Range(.Cells(j + 1, 1), .Cells(Rows.Count, Columns.Count))
            .ClearComments:   .Interior.ColorIndex = xlNone
         End With
'==End==REMOVE==============================

For Each cC In .Range("c3:c" & k)
   If dict.exists(LCase(Application.Trim(cC.Value))) Then
         With dict.Item(LCase(Application.Trim(cC.Value)))
               .Add Range(Cells(cC.Row, 1), Cells(cC.Row, n))
         End With 'dict.Item()
   End If