Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    
     Dim copyRange As Range, pasteRange As Range
     
    On Error Resume Next
    Set copyRange = Application.InputBox("Выделите ячейки, которые надо скопировать.", _
                    "Точное копирование", Default:=Selection.Address, Type:=8)
                    
    If copyRange Is Nothing Then Exit Sub
    
    Set pasteRange = Application.InputBox("Теперь выделите диапазон вставки." & vbCrLf & vbCrLf & _
                    "Диапазон должен быть равен по размеру исходному " & vbCrLf & _
                    "диапазону копируемых ячеек.", "Точное копирование", _
                    Default:=Selection.Address, Type:=8)
    
    If pasteRange.Cells.Count <> copyRange.Cells.Count Then
        MsgBox "Диапазоны копирования и вставки разного размера!", vbExclamation, "Ошибка копирования"
        
        Exit Sub
    End If
     
    If pasteRange Is Nothing Then
        Exit Sub
    Else
        pasteRange.Value = copyRange.Value
        
    End If
   Selection.Cells = ""
End Sub