Run Time error om previously flawless code

[bayles]

Hi all,

I have a VBA code that has worked for the last 2 or so years but for some reason has decided to not work now on some computers. I have refrained from installing updates on my excel for this reason for approximately 6 months since the update in Sep / Oct created other issues.

Attached is the code in question. I also wanted to attach some sample data but am unsure how to do that.

Would really appreciate any help with debugging.

Thanks
Ryan

Sub TEST ()
Range("P1").Select
ActiveCell.Value = "256"
ActiveCell.Offset(1, 0).Formula = "=R[-1]+1"


ActiveCell.Offset(1, 0).AutoFill Destination:=Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(10000, -15).End(xlUp).Offset(0, 15))
Columns("P:P").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False


' ADJUSTING FORMAT TO CHECK DATA
Dim rng1, rng2, rng3 As Range
For i = 1 To 5


    Set rng1 = Range("ZZ1").End(xlToLeft).Offset(0, 1)
    Set rng2 = Cells(Range("A10000").End(xlUp).Row, Range("ZZ1").End(xlToLeft).Offset(0, 4).Column)
    Set rng3 = Cells(Range("A10000").End(xlUp).Row, Range("ZZ1").End(xlToLeft).Offset(0, 1).Column)


' COPY / PASTE i-TH ITERATION
    Union(Columns(i), Columns(i + 5), Columns(i + 10), Columns(16)).Select
    Selection.Copy
    rng1.Select
    ActiveSheet.Paste
    
    ' SORT AND FIND NEXT BLANK CELL
    
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Checking").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Checking").Sort.SortFields.Add Key:=Range( _
        rng1, rng3), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Checking").Sort
        .SetRange Range(rng1, rng2)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
' GET ALL DATA INTO ONE COLUMN
If i > 1 Then


    Range(rng1, rng2).Select
    Selection.Cut
    rng1.Offset(0, -1).End(xlDown).Offset(1, -3).Select
    ActiveSheet.Paste
End If
Next i


    
Range(Columns(1), Columns(16)).Delete
ActiveSheet.Range(Columns(1), Columns(4)).RemoveDuplicates Columns:=Array(1, 2, 3), _
    Header:=xlNo
    
Columns("A:D").Select
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("D1:D10000" _
    ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
    .SetRange Range("A1:D10000")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With




'REMOVING BLANK CELLS
Range("A1").Select
For i = 1 To Range("D100000").End(xlUp).Row
    
    If Len(ActiveCell) + Len(ActiveCell.Offset(0, 1)) + Len(ActiveCell.Offset(0, 2)) = 0 Then
        ActiveCell.EntireRow.Delete
    Else
    ActiveCell.Offset(1, 0).Select
    End If
    
Next i


Cells.Select
Selection.Interior.Color = RGB(255, 255, 255)
Selection.VALIDATION.Delete


' FINDING INCOMPLETE ROWS
Range("E1").Select


For i = 1 To Application.WorksheetFunction.CountA(Range("A:A"))


    If Application.WorksheetFunction.CountBlank(Range(ActiveCell.Offset(0, -4), ActiveCell.Offset(0, -2))) > 0 Then
        ActiveCell = "1"
        ActiveCell.Offset(1, 0).Select
    Else
        ActiveCell = "0"
        ActiveCell.Offset(1, 0).Select
    End If




Next i
End Sub