Sub Макрос2()

[AF12] = [AF12] + 1

Static Pred(1 To 100) As Range
Dim target As Range, c88 As Range, Rn As Range
Dim c As Range, cc As Integer, cr As Integer
Dim Nr As Integer, Nc As Integer, Dr, Dc, i As Integer, Ist As Integer
i = 5
Do While Range("AC" & i) <> ""
  Set Rn = Range(Range("ac" & i).Text)
  Set target = Range(Range("ae" & i).Text)
  Set c88 = Range(Range("ag" & i))
  If Pred(i - 4) Is Nothing And c88 = Rn Then
    Set Pred(i - 4) = Rn
    If Rn = "" Then Rn = Range("af" & i): GoTo NextI
  End If
  Nr = Rn.Row - target.Row + 1: Nc = Rn.Column - target.Column + 1
  Dr = Rn.Top + Rn.Height / 2 - (target.Top + target.Height / 2)
  Dc = Rn.Left + Rn.Width / 2 - (target.Left + target.Width / 2)
  If Abs(Nc) >= Abs(Nr) Then
    'If c88.Column = target.Column Then GoTo NextI
    If Dc <> 0 Then a = Dr / Dc * c88.Width / c88.Height
    If c88.Column >= target.Column Then cc = c88.Column - 1 Else cc = c88.Column + 1
    cr = Round(a * (cc - target.Column) + target.Row, 0)
  Else
    'If c88.Row = target.Row Then GoTo NextI
    If Dr <> 0 Then a = Dc / Dr * c88.Height / c88.Width
    If c88.Row >= target.Row Then cr = c88.Row - 1 Else cr = c88.Row + 1
    cc = Round(a * (cr - target.Row) + target.Column, 0)
  End If
  If Not Pred(i - 4) Is Nothing Then Pred(i - 4).ClearContents
  If Range("ag" & i) = Range("ac" & i) Then Range(Range("ag" & i)).ClearContents
  Set c = Cells(cr, cc)
  Set Pred(i - 4) = c
  Range("ag" & i) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
  c.Formula = Range("af" & i).Text
NextI:
  i = i + 1
Loop

  Dr = Rn.Top + Rn.Height / 2 - (target.Top + target.Height / 2)
  Dc = Rn.Left + Rn.Width / 2 - (target.Left + target.Width / 2)