If Not Intersect(Target, [c1]) Is Nothing And Target.Count = 1 Then Dim arr, li&, lmp# .Undo: lmp = [c1]: .Undo arr = rng.Value For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) And IsNumeric(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li rng.Value = arr End If
If Not Intersect(Target, rng) Is Nothing Then If Not IsEmpty(Target) Then Target.Value = Evaluate(Target.Address & "*" & Replace(CStr(1 + [c1]), ",", ".")) End If
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With
End Sub
[/vba]
прекрасно отрабатывает, если в диапазоне больше 2-х ячеек. В том случае, когда в диапазон содержит только одну ячейку, то вылетает ошибка.
If Not Intersect(Target, [c1]) Is Nothing And Target.Count = 1 Then Dim arr, li&, lmp# .Undo: lmp = [c1]: .Undo arr = rng.Value For li = 1 To UBound(arr) If Not IsEmpty(arr(li, 1)) And IsNumeric(arr(li, 1)) Then arr(li, 1) = arr(li, 1) / (1 + lmp) * (1 + [c1]) Next li rng.Value = arr End If
If Not Intersect(Target, rng) Is Nothing Then If Not IsEmpty(Target) Then Target.Value = Evaluate(Target.Address & "*" & Replace(CStr(1 + [c1]), ",", ".")) End If
.Calculation = xlCalculationAutomatic .ScreenUpdating = True: .EnableEvents = True End With
End Sub
[/vba]
прекрасно отрабатывает, если в диапазоне больше 2-х ячеек. В том случае, когда в диапазон содержит только одну ячейку, то вылетает ошибка.