Efficiency… Efficiency… Efficiency…

Hi All,

Is there any way to bring more efficiency in this code.
I need to run this code on 100,000 rows every week and this takes hours to finish.

Can someone make this run faster please. You can see the attachment.
Thanks...

Option Explicit
Sub Find_Offset()

    Dim T As Date
    Dim I As Long
    Dim J As Long
    Dim X As Long
    Dim R As Long
    Dim A As Double
    Dim B As Double
             
    T = Now()
    I = 0
    J = 1
    X = 1
    R = Range(Selection, Selection.End(xlDown)).Rows.Count
    
    Application.ScreenUpdating = False
    
    With ActiveCell
        .Offset(0, 1).Columns("A:A").EntireColumn.Insert Shift:=xlToRight
        .Offset(-1, 1).Value = "Offsetting Pairs"
    End With
    
    For I = 0 To R - 2
        If IsEmpty(ActiveCell.Offset(I, 1)) Then
            A = ActiveCell.Offset(I, 0).Value
            For J = I + 1 To R - 1
                If IsEmpty(ActiveCell.Offset(J, 1)) Then
                    B = ActiveCell.Offset(J, 0).Value
                    If A + B = 0 Then
                        With ActiveCell
                            .Offset(I, 1).Value = X
                            .Offset(J, 1).Value = X
                        End With
                        X = X + 1
                        Exit For
                    End If
                End If
            Next
        End If
    Next
       
    MsgBox (X - 1) * 2 & " Offsetting values and " & R - ((X - 1) * 2) & _
            " Net values found in the range." & vbNewLine & _
            "Total time taken by this code to analyze is " & _
            Format((Now() - T) * 86400, "0.00") & " seconds."
   
    Application.ScreenUpdating = True

End Sub