first correct the check for the find not returning anything.

For Each aCell In Crng
    Set bCell = Erng.Find(What:=aCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not bCell Is Nothing Then
        aCell.Offset(, -1) = bCell.Offset(, -1)
        aCell.Offset(, 1) = bCell.Offset(, -2)
    End If
    Next
Plane on has 1 data point in column I so the range to process is I7:I1048576, which is a waste of time. Either find the end row by coming up from the bottom when using the End method. or check the 2nd row contains something.