Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Вставить скопированную строку на защищенном листе макросом
 
#1
21.05.2019 13:03:47
Доброго дня всем !

Не могу побороть проблему вставки строк после копирования макросом на защищенном листе.
Выдает ошибки при вставке (копируется нормально).
Защиту снимаю, в коде все перепробовал начиная от ActiveSheet.Paste и заканчивая Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.Locked = False и On Error Resume Next тоже применял - бесполезно
Кто что подскажет как справится с проблемой ?
Макрос и файл с примером прилагаю.
Код
Sub ПоставитьЗащитуЛиста()
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, _
DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True
End Sub
Код
Sub ВставитьСтроку()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="123"
'ActiveCell.EntireRow.Select
'Selection.Locked = False
'On Error Resume Next
'ActiveSheet.Paste
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
'On Error GoTo 0
Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub
Изменено: andreyka33 - 21.05.2019 13:07:42
 
 
 
#2
21.05.2019 13:35:41
Добрый день. Мне кажется, ошибка тут:
Код
Rows(ActiveCell.Row).PasteSpecial

По-моему, надо не СТРОКУ целиком указывать для вставки, а конкретный диапазон, или просто левую ячейку диапазона. Если, например, хотим вставить скопированные данные, начиная с ячейки столбца А в строку активной ячейки, то так:
Код
Range("A"& ActiveCell.Row).PasetSpecial

И далее по тексту.
Кому решение нужно - тот пример и рисует.
 
 
 
#3
21.05.2019 13:36:32
Макрос "КопироватьСтроку" у Вас ничего не копирует.
Попробуйте заменить строки на:
Код
ActiveCell.EntireRow(1).Select
Selection.Copy
Изменено: mamalot - 21.05.2019 13:37:04
 
 
 
#4
21.05.2019 13:41:25
Все нормально копирует - в макросе закомментируйте все защиту и при снятой защите все прекрасно работает - только что перепроверил
Пытливый - ваш совет к сожалению не помог
Изменено: andreyka33 - 21.05.2019 13:47:18
 
 
 
#5
21.05.2019 14:10:19
Код
Dim rhgForCopy

Sub КопироватьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    'ActiveCell.EntireRow.Copy ' Копирует строку с активной ячейкой
    Set rhgForCopy = ActiveCell.EntireRow
    
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub


Sub ВставитьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    rhgForCopy.Copy
    'ActiveCell.EntireRow.Select
    'Selection.Locked = False
    'On Error Resume Next
    'ActiveSheet.Paste
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    'On Error GoTo 0
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
 
 
 
#6
21.05.2019 14:12:05
А если так:
Код
Option Explicit
Public arr()

Sub КопироватьСтроку()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="123"
arr = ActiveCell.EntireRow.Value
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
End Sub


Sub ВставитьСтроку()
ActiveSheet.Unprotect Password:="123"
Range("a" & ActiveCell.Row).Resize(1, UBound(arr, 2)).Value = arr
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#7
21.05.2019 14:33:28
Благодарю Ivan.kh и Nordheim - оба варианта работают !    Только правда еще одна проблемка - корректно ВЫРЕЗАТЬ строку - ВСТАВИТЬ строку не получается на защищенном листе   попробую с учетом ваших вариантов
 
 
 
#8
21.05.2019 14:44:19
вырезать
Код
Dim rhgForCopy
 
Sub КопироватьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    'ActiveCell.EntireRow.Copy ' Копирует строку с активной ячейкой
    Set rhgForCopy = ActiveCell.EntireRow
     
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
     
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
 
 
Sub ВставитьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
'    rhgForCopy.Copy
    rhgForCopy.Cut
    'ActiveCell.EntireRow.Select
    'Selection.Locked = False
    'On Error Resume Next
    'ActiveSheet.Paste
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
'    Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    'On Error GoTo 0
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
Изменено: Ivan.kh - 21.05.2019 14:44:50
 
 
 
#9
21.05.2019 15:15:52
Благодарю еще раз Ivan.kh за помощь !
Добавил строку еще ActiveCell.EntireRow.Select  - чтоб визуально выделялось
Код
Dim rhgForCopy

Sub КопироватьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    Set rhgForCopy = ActiveCell.EntireRow
    ActiveCell.EntireRow.Select
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub


Sub ВставитьСтроку()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="123"
    rhgForCopy.Copy
    ActiveCell.EntireRow.Select
    'Selection.Locked = False
    'On Error Resume Next
    'ActiveSheet.Paste
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
    'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    'On Error GoTo 0
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
 
 
 
#10
21.05.2019 15:51:33
Так будет короче :)

Код
Dim rngForCopy As Range
Sub КопироватьСтроку()
   Set rngForCopy = ActiveCell.EntireRow
   rngForCopy.Select  ' визуально выделяет
End Sub
  
Sub ВставитьСтроку()
    ActiveSheet.Unprotect Password:="123"
    rngForCopy.Copy
    ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
End Sub
Изменено: sokol92 - 21.05.2019 16:01:41
Владимир
 
 
 
#11
22.05.2019 17:02:57
sokol92 к сожалению ваш вариант выдает ошибку на строке rngForCopy.Copy

Нужны рекомендации по следующему коду - не хочет работать:  вырезать только значения (формат исходной строки не трогаем)  и  вставить в новую строку  значения и все форматы исходной строки. Стандартный Cut  не подходит - он вырезает формат исходной строки.
Ошибка на строке ActiveSheet.Paste ( причем без строки rhgForCopy.ClearContents макрос нормально работает как простое копирование)
Код
Dim rhgForCopy

Sub ВырезатьКонтентСтроки()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="88"
       Set rhgForCopy = ActiveCell.EntireRow
       ActiveCell.EntireRow.Select
    ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
 
 
Sub ВставитьФормат_и_КонтентИсхСтроки()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="88"
      ActiveCell.EntireRow.Select
      rhgForCopy.Copy
      rhgForCopy.ClearContents
      'ActiveCell.EntireRow.ClearContents
     'On Error Resume Next
      ActiveSheet.Paste
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
    'On Error GoTo 0
    Application.EnableEvents = True
    'Application.ScreenUpdating = True
End Sub
Изменено: andreyka33 - 22.05.2019 17:04:35
 
 
 
#12
22.05.2019 17:26:35
Цитата
andreyka33 написал:
(формат исходной строки не трогаем)
Цитата
andreyka33 написал:
вставить в новую строку  значения и все форматы исходной строки
Так, всё-таки, трогаем формат исходной строки или нет?
 
 
 
#13
22.05.2019 17:47:21
формат исходной строки не трогаем - вырезаются только значения
а в новую строку попадают вырезанные значения из исходной строки и копируется формат исходной строки
Изменено: andreyka33 - 22.05.2019 17:49:07
 
 
 
#14
22.05.2019 19:28:43
Попробовал так сделать на основе макросов выше  - вроде работает но время от времени случайным образом ругается на rhgForCopy.Copy
Код
Dim rhgForCopy
Public arr()

Sub ВырезатьКонтент_2_без_формата()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="88"

arr = ActiveCell.EntireRow.Value
Set rhgForCopy = ActiveCell.EntireRow
ActiveCell.EntireRow.Select
ActiveCell.EntireRow.ClearContents

ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub

Sub ВставитьКонтент_и_Формат_2()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="88"

rhgForCopy.Copy
ActiveCell.EntireRow.Select
Range("a" & ActiveCell.Row).Resize(1, UBound(arr, 2)).Value = arr
Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteFormats 'вставить только формат исходной строки
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
'Rows(ActiveCell.Row).PasteSpecial

ActiveSheet.Protect Password:="88", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub
 
 
 
Страницы: 1
Наверх