Свойство locked vba excel

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

Private Sub OK_Click()
'снятие защиты с листа - работает
Range("A1:U200").Select
Selection.Locked = False
Selection.FormulaHidden = False
        ' определение последней заполненой ячейки
        'iRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
'iClm = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
        ' если выбрано исполнитель
    If But1.Value = True Then
        Dim cell As Range
        For Each cell In [A1:A200]
            If cell.Value Like "*Исполнитель*" Then
                cell.Activate
            End If
            Next
                x = ActiveCell.Row
                y = ActiveCell.Column
                While cells(x, y + 1) = ""
                cells(x, y + 1) = "Isp"
                ВставитьКартинку cells(x, y + 1), "D:Otheravatar1727_1.gif"
                cells(x, y + 1).Activate
                Range("II").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                Wend
                    'цикл для вставки во все листы книги
                    If Foreach.Value = True Then
                    For ListI = 1 To 3
                    Worksheets(ListI).Activate
                        Dim cell6 As Range
                        For Each cell6 In [A1:A200]
                        If cell6.Value Like "*Исполнитель*" Then
                        cell6.Activate
                    End If
                    Next
                        xx = ActiveCell.Row
                        yyy = ActiveCell.Column
                        While cells(xx, yyy + 1) = ""
                        cells(xx, yyy + 1) = "Isp"
                        ВставитьКартинку cells(xx, yyy + 1), "D:Otheravatar1727_1.gif"
                        cells(xx, yyy + 1).Activate
                        Selection.Name = "II"
                        Selection.Locked = True
                        Selection.FormulaHidden = False
                        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                        Wend
            Next
            End If
            'конец цикла
        ' если выбрано руководитель
    ElseIf But2.Value = True Then
    
    Dim cell2 As Range
    For Each cell2 In [A1:A200]
    If cell2.Value Like "*Исполнитель*" Then
    cell2.Activate
    End If
    Next
    x = ActiveCell.Row
    y = ActiveCell.Column
    If Not cells(x, y + 1) = "Isp" Then
        MsgBox "Выберите подпись исполнителя!"
    Else
            Dim celll As Range
            For Each celll In [A1:A200]
                If celll.Value Like "*Руководитель проверки*" Then
                celll.Activate
                End If
            Next
                a = ActiveCell.Row
                z = ActiveCell.Column
                While cells(a, z + 1) = ""
                cells(a, z + 1) = "Ruc"
                ВставитьКартинку cells(a, z + 1), "D:Otherav-6193.jpg"
                Range("II").Select
                ActiveSheet.Unprotect
                cells.Select
                Selection.Locked = True
                Selection.FormulaHidden = False
                ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                Wend
        'начало цикла
        If Foreach.Value = True Then
        For ListII = 1 To 3
            Worksheets(ListII).Activate
            Dim cell8 As Range
            For Each cell8 In [A1:A200]
                    If cell8.Value Like "*Руководитель проверки*" Then
                    cell8.Activate
                End If
                Next
                    aaa = ActiveCell.Row
                    zzz = ActiveCell.Column
                    While cells(aaa, zzz + 1) = ""
                        cells(aaa, zzz + 1) = "Ruc"
                        ВставитьКартинку cells(aaa, zzz + 1), "D:Otherav-6193.jpg"
                        Range("A1:U200").Select
                        Selection.Locked = True
                        Selection.FormulaHidden = False
                        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                   Wend
            Next ListII
            End If
        'конец цикла
    End If
    End If
End Sub
 
Function ВставитьКартинку(ByRef cell As Range, ByVal Pic As String) As Boolean
    ' получает в качестве параметра ссылку на ячейку для вставки
    ' и путь к файлу с картинкой.
    ' если картинка вставлена успешно, возвращает TRUE
    On Error Resume Next: Err.Clear
    Dim ph As Picture: Set ph = cell.Parent.Pictures.Insert(Pic)
    ВставитьКартинку = Err.Number = 0
    ph.Top = cell.Top: ph.Left = cell.Left: k = ph.Width / ph.Height
    ph.Width = cell.Width: ph.Height = ph.Width / k
    cell.EntireRow.RowHeight = ph.Height
    Selection.Name = "Isp"
End Function

1
2
3
4
5
6
7
8
9
10

Sub Макрос1()
 
    Cells.Select
    Selection.Locked = False
    Selection.FormulaHidden = False
    Range("D15").Select
    Selection.Locked = True
    Selection.FormulaHidden = False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub