Проблема с копированием ячеек - VBA - Ответ 2654877

Sub price_copy()
    Dim i As String
    Dim j As String
    
    Workbooks.Open ('2.xls')
    
    Workbooks('1.xls').Activate
    Range('D4').Activate
1:
3:  If (IsEmpty(ActiveCell.Value) = True) Then
        ActiveCell.Offset(1, 0).Select
        GoTo 3
    End If
    If (IsEmpty(ActiveCell.Value) = False) Then i = ActiveCell.Value
    
    
    If ActiveCell.Value = 'end' Then GoTo 2
    
    Workbooks('2.xls').Activate
    Columns('A:A').Select
    
    Selection.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
    On Error GoTo 4
   
    ActiveCell.Offset(0, 7).Select
    j = ActiveCell.Value
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = False
    
    Workbooks('1.xls').Activate
    Columns('D:D').Select
    Selection.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
    ActiveCell.Offset(0, 7).Select
    ActiveCell.Value = j
    ActiveCell.Offset(1, -7).Select
    
GoTo 1
 
2:
 
Exit Sub
4:
    
    Workbooks('1.xls').Activate
    Columns('D:D').Select
    Selection.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
    ActiveCell.Interior.ColorIndex = 3
    ActiveCell.Offset(1, 0).Select
    Err.Clear
    'Resume Next
    GoTo 3
    
End Sub