Снять защиту листа при добавлении нового сотрудника

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Снять защиту листа при добавлении нового сотрудника (Макросы/Sub)

lebensvoll

Дата: Пятница, 13.07.2018, 18:00 | Сообщение № 1

Группа: Проверенные

Ранг: Старожил

Сообщений: 1002

Репутация: 30 ±

Замечаний: 0% ±

Excel 2010

Добрый вечер, многоуважаемые форумчане!!!
Прошу Вас, помочь дополнить действующий код
1. Снять защиту листа без запроса пароля
2. Срабатывание действующего макроса
3. Установить защиту листа без запроса пароля
Данный код выдает ошибку когда лист запоролен а нужно добавить нового сотрудника
Сам код:
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("B7:B37")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Сотрудники").Range("Сотрудники"), Target) = 0 Then
                lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then
                        Worksheets("Сотрудники").Range("Сотрудники").Cells(Worksheets("Сотрудники").Range("Сотрудники").Rows.Count + 1, 1) = Target
                        Sheets("Сотрудники").Range("B1:B500").Sort Key1:=Sheets("Сотрудники").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If

End Sub

[/vba]
Заранее спасибо огромнейшее!!!

Код

[/vba]
Заранее спасибо огромнейшее!!!lebensvoll

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Пятница, 13.07.2018, 18:02

Ответить

СообщениеДобрый вечер, многоуважаемые форумчане!!!
Прошу Вас, помочь дополнить действующий код
1. Снять защиту листа без запроса пароля
2. Срабатывание действующего макроса
3. Установить защиту листа без запроса пароля
Данный код выдает ошибку когда лист запоролен а нужно добавить нового сотрудника
Сам код:
[vba]

Код

[/vba]
Заранее спасибо огромнейшее!!!

Автор - lebensvoll
Дата добавления - 13.07.2018 в 18:00

_Boroda_

Дата: Пятница, 13.07.2018, 19:41 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 17006

Репутация: 6667 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Вначале макроса (вернее, не вначале, а после всех If-ов) снимаете пароль
[vba]

Код

Sheets("лист5894").Unprotect Password:="0"

[/vba]
А после всех операций ставите обратно
[vba]

Код

Sheets("лист5894").protect Password:="0"

[/vba]

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

lebensvoll

Дата: Пятница, 13.07.2018, 20:56 | Сообщение № 3

Группа: Проверенные

Ранг: Старожил

Сообщений: 1002

Репутация: 30 ±

Замечаний: 0% ±

Excel 2010

_Boroda_, не получается я уже чуть ли не через каждый if пытался расставить предложенный Вами код
Вот смотрите:
Имеется файл в нем листы: Январь; Февраль; Март и т.д. (и лист "Сотрудники") каждый из этих листов запоролен макросом устонавливается на все листы сразу:
[vba]

Код

Sub Установить_Защиту() 'Макрос защиты листов

'отключаем обновление экрана
Application.ScreenUpdating = False

    Dim iSht As Worksheet

    For Each iSht In Worksheets
    iSht.Protect password:="09052002", DrawingObjects:=True, Contents:=True, Scenarios:=True
    Next iSht

'Возвращаем обновление экрана
Application.ScreenUpdating = True

   MsgBox "Защита установлена"
End Sub

[/vba]
На каждом Листе (Январь; Февраль и т.д.) есть столбец где применяется выпадающий список с работой этого макроса:
[vba]

Код

[/vba]
И как сделать так чтоб он перед добавлением вначале снял защиту (чтоб можно было внести нового сотрудника и потом сразу же запоролил) но без запроса самого пароля

Код

[/vba]
И как сделать так чтоб он перед добавлением вначале снял защиту (чтоб можно было внести нового сотрудника и потом сразу же запоролил) но без запроса самого пароляlebensvoll

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Пятница, 13.07.2018, 20:58

Ответить

Сообщение_Boroda_, не получается я уже чуть ли не через каждый if пытался расставить предложенный Вами код
Вот смотрите:
Имеется файл в нем листы: Январь; Февраль; Март и т.д. (и лист "Сотрудники") каждый из этих листов запоролен макросом устонавливается на все листы сразу:
[vba]

Код

Автор - lebensvoll
Дата добавления - 13.07.2018 в 20:56

RAN

Дата: Пятница, 13.07.2018, 22:02 | Сообщение № 4

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Цитата lebensvoll, 13.07.2018 в 20:56, в сообщении № 3 (

)

я уже пытался

И где в ваших попытках Unprotect . Ну хоть в одном месте?
[offtop]подвернуласьсовершенно мерзкая кнопка репутация. метился в цитату, попал на неё.[/offtop]

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Пятница, 13.07.2018, 22:15

Ответить

lebensvoll

Дата: Пятница, 13.07.2018, 22:22 | Сообщение № 5

Группа: Проверенные

Ранг: Старожил

Сообщений: 1002

Репутация: 30 ±

Замечаний: 0% ±

Excel 2010

RAN, я как понял то вот он
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("B7:B37")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Сотрудники").Range("Сотрудники"), Target) = 0 Then
                lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then

                    Sheets("Сотрудники").Unprotect password:="09052002"

                        Worksheets("Сотрудники").Range("Сотрудники").Cells(Worksheets("Сотрудники").Range("Сотрудники").Rows.Count + 1, 1) = Target
                        Sheets("Сотрудники").Range("B1:B500").Sort Key1:=Sheets("Сотрудники").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If

    Sheets("Сотрудники").Protect password:="09052002"

End Sub

[/vba]
Но все равно ошибка (((( вот сами смотрите

К сообщению приложен файл: 4521308.xlsm (47.4 Kb)

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Пятница, 13.07.2018, 22:23

Ответить

lebensvoll

Дата: Пятница, 13.07.2018, 22:27 | Сообщение № 6

Группа: Проверенные

Ранг: Старожил

Сообщений: 1002

Репутация: 30 ±

Замечаний: 0% ±

Excel 2010

RAN, _Boroda_, все спасибо за посыл разобрался
так нужно было
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("B7:B37")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Сотрудники").Range("Сотрудники"), Target) = 0 Then
                lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then

                    Worksheets("Сотрудники").Unprotect password:="09052002"

                        Worksheets("Сотрудники").Range("Сотрудники").Cells(Worksheets("Сотрудники").Range("Сотрудники").Rows.Count + 1, 1) = Target
                        Sheets("Сотрудники").Range("B1:B500").Sort Key1:=Sheets("Сотрудники").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If

    Worksheets("Сотрудники").Protect password:="09052002"

End Sub

[/vba]
Исправил Worksheets а не Sheets

Цитата

подвернуласьсовершенно мерзкая кнопка репутация. метился в цитату, попал на неё.

Это ВЫ ругаетесь!?
Да я ведь только учусь. В начале решения какой то либо проблемы у меня всегда паника, хотя ответ ВОТ перед носом его прям дали "даже разжевали, ГЛОТАЙ". Но увы даже при этом совершаешь ошибки и лишь собравшись с мыслями (и в 1000 раз пробывания) ты находишь И ГЛОТАЕШЬ кусок ЖЕЛАЕМОГО предложенного ЛЮДЬМИ...СПАСИБО ОГРОМНЕЙШЕЕ не огорчайтесь пожалуйста когда ни будь я исправлюсь

RAN, _Boroda_, все спасибо за посыл разобрался
так нужно было
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("B7:B37")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Сотрудники").Range("Сотрудники"), Target) = 0 Then
                lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then

                    Worksheets("Сотрудники").Unprotect password:="09052002"

                        Worksheets("Сотрудники").Range("Сотрудники").Cells(Worksheets("Сотрудники").Range("Сотрудники").Rows.Count + 1, 1) = Target
                        Sheets("Сотрудники").Range("B1:B500").Sort Key1:=Sheets("Сотрудники").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If

    Worksheets("Сотрудники").Protect password:="09052002"

End Sub

[/vba]
Исправил Worksheets а не Sheets

Цитата

подвернуласьсовершенно мерзкая кнопка репутация. метился в цитату, попал на неё.

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Пятница, 13.07.2018, 22:45

Ответить

СообщениеRAN, _Boroda_, все спасибо за посыл разобрался
так нужно было
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("B7:B37")) Is Nothing Then
        If IsEmpty(Target) Then Exit Sub
            If WorksheetFunction.CountIf(Sheets("Сотрудники").Range("Сотрудники"), Target) = 0 Then
                lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                    If lReply = vbYes Then

                    Worksheets("Сотрудники").Unprotect password:="09052002"

                        Worksheets("Сотрудники").Range("Сотрудники").Cells(Worksheets("Сотрудники").Range("Сотрудники").Rows.Count + 1, 1) = Target
                        Sheets("Сотрудники").Range("B1:B500").Sort Key1:=Sheets("Сотрудники").Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
                    End If
            End If
    End If

    Worksheets("Сотрудники").Protect password:="09052002"

End Sub

[/vba]
Исправил Worksheets а не Sheets

Цитата

подвернуласьсовершенно мерзкая кнопка репутация. метился в цитату, попал на неё.

Автор - lebensvoll
Дата добавления - 13.07.2018 в 22:27

RAN

Дата: Пятница, 13.07.2018, 23:13 | Сообщение № 7

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Цитата lebensvoll, 13.07.2018 в 22:27, в сообщении № 6 ()