Страницы: 1
RSS
Защита выпадающего списка от копирования/вставки
 
Здравсnвтуйте!
Существует проблема по защите ячеек из выпадающего листа от вставки после копирования.
Известно, что при этом слетает сам выпадающий список.
Есть такой макрос, который призван защитить определенные области от вставок , в том числе и от вставки из другого источника.

Косяк макроса в том, что он отключает команду Вставить на всех листах когда речь идет о копировании из внешнего источника.
При копировании внутри самого файла- все работает отлично.

Этот кусок вставляется в ThisWorkbook:
Код
Option Explicit
Private Sub Workbook_Activate()
     'Force the current selection to be selected, triggering the appropriate
     'state of the cut, copy & paste commands
    Call ChkSelection(ActiveSheet)
    Application.CellDragAndDrop = False
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
    Application.CellDragAndDrop = True
End Sub
Private Sub Workbook_Deactivate()
     'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
    Application.CellDragAndDrop = True
End Sub
Private Sub Workbook_Open()
     'Force the current selection to be selected, triggering the appropriate
     'state of the cut, copy & paste commands
    Call ChkSelection(ActiveSheet)
    Application.CellDragAndDrop = False
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call ChkSelection(Sh)
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
     'Toggle the cut, copy & paste commands on selected ranges
    Call ChkSelection(Sh)
End Sub
а этот кусок вставляется в Модуль:
Код
Option Explicit
Public Function InRange(Range1 As Range, Range2 As Range) As Boolean
' Added function to check if Cell is In Range
' returns True if Range1 is within Range2'
Dim InterSectRange As Range
    Set InterSectRange = Application.Intersect(Range1, Range2)
    InRange = Not InterSectRange Is Nothing
    Set InterSectRange = Nothing
End Function
Sub ChkSelection(ByVal Sh As Object)
    'Added Primarily to have one place to set restrictions
    'It also fixes the issue where a cell you don't want to
    'copy/paste from/to is already selected, but you
    'came from a sheet that wasn't protected.
     
    Dim rng As Range
    Set rng = Range(Selection.Address)
 
    Select Case Sh.Name
    Case Is = "Sheet1"
        'Disable copy and paste for anything in column A
        If InRange(rng, Columns("A")) Then
            Call ToggleCutCopyAndPaste(False)
        Else
            Call ToggleCutCopyAndPaste(True)
        End If
 
    Case Is = "Sheet2"
        'Disable copy and paste for anything in range G1 to G20
        If InRange(rng, Range("G1:G20")) Then
            Call ToggleCutCopyAndPaste(False)
        Else
            Call ToggleCutCopyAndPaste(True)
        End If
 
    Case Else
        Call ToggleCutCopyAndPaste(True)
    End Select
 
End Sub
Sub ToggleCutCopyAndPaste(Allow As Boolean)
     'Activate/deactivate cut, copy, paste and pastespecial menu items
    Call EnableMenuItem(21, Allow) ' cut
    Call EnableMenuItem(19, Allow) ' copy
    Call EnableMenuItem(22, Allow) ' paste
    Call EnableMenuItem(755, Allow) ' pastespecial
      
 
     'Drag and Drop Disabled from Original code due to deselecting what has been
     'copied and not allowing paste.  Moved to when workbook opens.
     'Drag and drop will not be allowed for entire workbook.
      
     'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
    With Application
        Select Case Allow
        Case Is = False
            .OnKey "^c", "CutCopyPasteDisabled"
            .OnKey "^v", "CutCopyPasteDisabled"
            .OnKey "^x", "CutCopyPasteDisabled"
            .OnKey "+{DEL}", "CutCopyPasteDisabled"
            .OnKey "^{INSERT}", "CutCopyPasteDisabled"
        Case Is = True
            .OnKey "^c"
            .OnKey "^v"
            .OnKey "^x"
            .OnKey "+{DEL}"
            .OnKey "^{INSERT}"
        End Select
    End With
End Sub
  
Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
     'Activate/Deactivate specific menu item
    Dim cBar As CommandBar
    Dim cBarCtrl As CommandBarControl
    For Each cBar In Application.CommandBars
        If cBar.Name <> "Clipboard" Then
            Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)
            If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled
        End If
    Next
End Sub
  
Sub CutCopyPasteDisabled()
     'Inform user that the functions have been disabled
    MsgBox "Sorry! Cutting, copying and pasting have been disabled for the specified range."
End Sub
 
Посмотрите здесь. И кода не нужно.  :)  
Изменено: sokol92 - 29.10.2020 13:25:17
Владимир
 
Цитата
sokol92 написал:
Посмотрите  здесь . И кода не нужно.    
Спасибо, за отклик, помучилась, но сделала. получилось! Однако, дело в том, что после объединения появляется теперь уже 2 столбца, вместо одного. далее этот столбец подлежит копированию в другой файл, где нет лишних столбцов, и получается он не вставится уже туда, верно? Для встави потребуется отедльный пустой столбец =(
 
Помечаем "защищаемые" ячейки например так
Код
range("c3").ID="NoCopy"


и
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("c3:c5")) Is Nothing Then
    For Each Cell In Intersect(Target, Range("c3:c5"))
        If Cell.ID <> "NoCopy" Then
            With Application
                .EnableEvents = False
                .Undo
                .EnableEvents = True
            End With
            Exit For
        End If
    Next
End If
End Sub


Попытка скопировать на них - будет пресечена. Если только не копируются ячейки с3:c5 в самих себя, но при этом у них остаются теже настройки, так что не страшно. Ну или делать уникальные ID И их сравнивать.
Изменено: БМВ - 30.10.2020 10:36:38
По вопросам из тем форума, личку не читаю.
 
Цитата
Salta-301 написал:
Для встави потребуется отедльный пустой столбец
Так можно точно так же объединить две ячейки в одном столбце.
Владимир
 
Цитата
sokol92 написал:
Так можно точно так же объединить две ячейки в одном столбце.
та же фигня, но теперь со строками дополнительными  :D

Владимир приветствую. Лучше мой изврат зацените  ;)
По вопросам из тем форума, личку не читаю.
 
Здравствуйте, Михаил!
Свойству Range.Id я когда-то пытался "дать ладу" (для других целей). Главный недостаток - при закрытии и последующем открытии файла оно не сохраняется.

Теперь по существу темы. Мы хотим, чтобы ячейку корректировали только через выпадающий список и никаким другим образом (в том числе, вставкой значений, нажатием на клавишу del и т.п.). Надежных способов, кроме указанного в #2, я пока не видел.
Владимир
 
Цитата
sokol92 написал:
Главный недостаток - при закрытии и последующем открытии файла оно не сохраняется.
это не так.
Изменено: БМВ - 30.10.2020 16:00:42
По вопросам из тем форума, личку не читаю.
 
У меня (2016, 32-) в примере из #4

Код
Debug.Print Range("C3").ID

выдает пустой ответ. И я не могу через выпадающий список поменять в ячейке C3 значение 1 на 3.
Владимир
 
да, это мне показалось что переоткрыл. Да тут конечно хуже, нужно инициализировать каждый раз при открытии.  Но зато работает.
По вопросам из тем форума, личку не читаю.
 
Да, интересный трюк!
Владимир
 
Чуть доработал.

Код
Private Sub Workbook_Open()
For Each Cell In Sheet1.Range("c3:c5")
    Cell.ID = Cell.Address(External:=True)
Next
End Sub


Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("c3:c5")) Is Nothing Then
    For Each Cell In Intersect(Target, Range("c3:c5"))
        If Cell.ID <> Cell.Address(External:=True) Then
            With Application
                .EnableEvents = False
                .Undo
                .EnableEvents = True
            End With
            Exit For
        End If
    Next
End If
End Sub
Изменено: БМВ - 30.10.2020 17:22:31
По вопросам из тем форума, личку не читаю.
 
Да, работает. От "Cпециальная вставка/вставить связь" не защищает, равно как и метод, указанный в ответе #2.
Владимир
 
Цитата
sokol92 написал:
"Cпециальная вставка/вставить связь" не защищает
это какой то вредительский метод.
По вопросам из тем форума, личку не читаю.
 
Можно, наверное, этого вредителя обезвредить методом, обсуждавшимся нами здесь, но это хлопотно. :)

Проще в Вашем коде строку 4 написать так:
Код
If cell.ID <> cell.Address(External:=True) Or cell.HasFormula Then
Изменено: sokol92 - 30.10.2020 21:13:01
Владимир
 
Цитата
sokol92 написал:
но это хлопотно.
Хлопоты бубновые пиковый интерес.  :D
Цитата
sokol92 написал:
написать так
но тогда не только выпадающий защитим, а вдруг ненужно.
По вопросам из тем форума, личку не читаю.
 
Друзья, добрый день!
Вы обсудили все, но не мой код =))
Я думала я смогу его поправить, ведь у него всего один косяк.
А в остальном вроде работает.
 
Всем доброго времени суток!
Код внутри файла вырубает копирование(и вставку) полностью, хотя призван блокировать его лишь в указанных диапазонах :  K1:K3 и G1:G3
Drag and drop работает правильно: везде-да, в указанных-диапазонах нет.
Но почему, так же не работает копирование?

Помогите пожалуйста, я скоро с ума сойду.. в интернете не могу найти ответа...
Страницы: 1
Наверх