Sub ertert()
Dim x, i&, j&, s$
x = Sheets("факт").Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 2 To UBound(x)
         For j = 1 To UBound(x, 2) Step 2
             If Len(x(i, j)) Then
                 s = x(i, j) & "~" & x(1, j + 1)
                 If Not .Exists(s) Then .Item(s) = x(i, j + 1)
             End If
         Next j
     Next i
     With Sheets("расчет").Range("A1").CurrentRegion
         .Parent.Activate: x = .Value: .Font.Color = vbBlack
     End With
     For i = 2 To UBound(x)
         For j = 2 To UBound(x, 2)
             If Len(x(i, j)) Then
                 s = x(i, 1) & "~" & x(1, j)
                 If .Exists(s) Then
                     Cells(i, j).Value = .Item(s)
                     Cells(i, j).Font.Color = vbRed
                 End If
             End If
         Next j
     Next i
End With
End Sub