Здравсnвтуйте!
Существует проблема по защите ячеек из выпадающего листа от вставки после копирования.
Известно, что при этом слетает сам выпадающий список.
Есть такой макрос, который призван защитить определенные области от вставок , в том числе и от вставки из другого источника.
Косяк макроса в том, что он отключает команду Вставить на всех листах когда речь идет о копировании из внешнего источника.
При копировании внутри самого файла- все работает отлично.
Этот кусок вставляется в ThisWorkbook:
а этот кусок вставляется в Модуль:
Существует проблема по защите ячеек из выпадающего листа от вставки после копирования.
Известно, что при этом слетает сам выпадающий список.
Есть такой макрос, который призван защитить определенные области от вставок , в том числе и от вставки из другого источника.
Косяк макроса в том, что он отключает команду Вставить на всех листах когда речь идет о копировании из внешнего источника.
При копировании внутри самого файла- все работает отлично.
Этот кусок вставляется в 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 |