Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    DateNameEvent Target, Range(Cells(3, 7), Cells(20, 7))
End Sub

Sub DateNameEvent(Target As Range, KeyCells As Range)
Application.EnableEvents = False
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
    If Cells(Target.Row, 7) <> "Выполнено" Then
        If MsgBox(Подтвердить выполнение " & "(" & Cells(ActiveCell.Row, ActiveCell.Column - 3).Value & ")" & "?" & Chr(13) & _
        "Исполнитель:" & Cells(ActiveCell.Row, ActiveCell.Column - 4).Value & ".", vbExclamation + vbYesNo, "Выполнение задания") = vbYes Then
            ActiveCell.Value = "Выполнено"
            ActiveCell.Interior.Color = 52224
            Cells(Target.Row, 6).Interior.Color = RGB(255, 255, 255)
            Cells(Target.Row, 24).Value = Application.UserName
            Cells(Target.Row, 25).Value = Date
            Cells(Target.Row, 26).Value = Time
        Else
            Exit Sub
        End If
        Else
        If MsgBox("Задание " & "(" & Cells(ActiveCell.Row, ActiveCell.Column - 3).Value & ") уже выполнено, убрать отметку" & "?" & Chr(13) & _
        "Исполнитель:" & Cells(ActiveCell.Row, ActiveCell.Column - 4).Value & ".", vbInformation + vbYesNo, "Выполнение задания") = vbYes Then
            ActiveCell.Value = "Подтвердить выполнение"
            ActiveCell.Interior.Color = 13497086
            Cells(Target.Row, 27).Value = Application.UserName
            Cells(Target.Row, 28).Value = Date
            Cells(Target.Row, 29).Value = Time
                If Cells(ActiveCell.Row, ActiveCell.Column - 1) < Date Then
                    Cells(Target.Row, 6).Interior.Color = 255
                End If
        Else
            Exit Sub
        End If
    End If
End If
Application.EnableEvents = True
End Sub

iShCodeName = Worksheets(1).CodeName

iShCodeName = Worksheets(1).CodeName
iShCodeName.Activate

'По уникальному имени
УникИмяЛиста
 
'По индексу
Worksheets(N)
 
'По имени листа на ярлычке
Worksheets("Имя листа")

Randomize

rDig = Int(Rnd * 7 + 1)

Sub AxeRND()
Dim arr()
Range(Cells(1, 1), Cells(20, 3)).ClearContents
        For i = 1 To 3
Return1:
        rDig = Int(Rnd * 7 + 1)
            Cells(1, i) = rDig
                If Cells(1, 1) <> "" And Cells(1, 2) <> "" And Cells(1, 3) <> "" Then
                    If Cells(1, 1) = Cells(1, 2) Or Cells(1, 1) = Cells(1, 3) Or Cells(1, 2) = Cells(1, 3) Then
                        GoTo Return1
                    End If
                End If
        Next
    For j = 2 To 7
        'Randomize
Return2:
        For i = 1 To 3
        rDig = Int(Rnd * 7 + 1)

    LR = Cells(Rows.Count, 1).End(xlUp).Row
Erase arr
    arr = Range(Cells(1, 1), Cells(LR + 1, 3))
            Cells(j, i) = rDig
                If rDig = arr(j, 1) Or rDig = arr(j, 2) Or rDig = arr(j, 3) Then
                    GoTo Return2
                End If
        Next i
            For x = 1 To j - 1
                If ((Cells(j, 1) = arr(x, 1) Or Cells(j, 1) = arr(x, 2) Or Cells(j, 1) = arr(x, 3)) And (Cells(j, 2) = arr(x, 1) Or Cells(j, 2) = arr(x, 2) Or Cells(j, 2) = arr(x, 3))) Or _
                    ((Cells(j, 1) = arr(x, 1) Or Cells(j, 1) = arr(x, 2) Or Cells(j, 1) = arr(x, 3)) And (Cells(j, 3) = arr(x, 1) Or Cells(j, 3) = arr(x, 2) Or Cells(j, 3) = arr(x, 3))) Or _
                    ((Cells(j, 2) = arr(x, 1) Or Cells(j, 2) = arr(x, 2) Or Cells(j, 2) = arr(x, 3)) And (Cells(j, 3) = arr(x, 1) Or Cells(j, 3) = arr(x, 2) Or Cells(j, 3) = arr(x, 3))) Then
                    GoTo Return2
                End If
            Next
    Next j
End Sub

Private Sub CloseSaveAll()
Dim MyPath$, MyName$
MyPath = ThisWorkbook.Path
MyName = ThisWorkbook.Name
    GetObject(MyPath & "\" & MyName).Close False
    ThisWorkbook.Close True
End Sub

Private Sub Admin_Menu_Click()
Admin_Menu_Initialize
Load Window_Menu
Window_Menu.Show vbModeless
End Sub

Private Sub Admin_Menu_Initialize()
If ActiveWorkbook.MultiUserEditing = True Then
Window_Menu.ExclusiveAccess_CheckBox.Value = True
Else
Window_Menu.ExclusiveAccess_CheckBox.Value = False
End If
End Sub

Private Sub ExclusiveAccess_CheckBox_Click()
Dim MyPath$, MyName$
MyPath = ThisWorkbook.Path
MyName = ThisWorkbook.Name
On Error Resume Next
If ExclusiveAccess_CheckBox.Value = False Then
Application.DisplayAlerts = False
ActiveWorkbook.ExclusiveAccess
Application.DisplayAlerts = True
Else
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs MyPath & "\" & MyName, AccessMode:=xlShared
Application.DisplayAlerts = True
End If
End Sub

'Действие при установки/снятии флажка "Включить общий доступ к книге"
Private Sub ExclusiveAccess_CheckBox_Click()
    Dim MyPath$, MyName$    MyPath = ThisWorkbook.Path
    MyName = ThisWorkbook.Name
Application.DisplayAlerts = False
    If ActiveWorkbook.MultiUserEditing Then
        ActiveWorkbook.ExclusiveAccess = True
    Else
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs MyPath & "\" & MyName, AccessMode:=xlShared
        Application.DisplayAlerts = True
    End If
End Sub

'Действие при установки/снятии флажка "Включить общий доступ к книге"
Private Sub ExclusiveAccess_CheckBox_Click()
Application.DisplayAlerts = False
    If ActiveWorkbook.MultiUserEditing Then
        ActiveWorkbook.ExclusiveAccess = True
    Else
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs AccessMode:=xlShared
        Application.DisplayAlerts = True
    End If
End Sub

ActiveWorkbook.SaveAs AccessMode:=xlShared

Sub Сравнить_и_добавить()
Dim i&, j&, x&, y&, LastRow_1&, LastRow_2&
Dim aaa()
Dim bbb()
    LastRow_1 = Cells(Rows.Count, 1).End(xlUp).Row
    LastRow_2 = Cells(Rows.Count, 6).End(xlUp).Row
ReDim aaa(LastRow_1 - 1, 2)
ReDim bbb(LastRow_2 - 1, 2)
'заполняем массивы данными
    For i = 0 To UBound(aaa)
                aaa(i, 0) = Cells(i + 1, 1) 'Номер1
                aaa(i, 1) = Cells(i + 1, 2) 'Дата1
                aaa(i, 2) = Cells(i + 1, 3) 'Условие1
    Next
    For j = 0 To UBound(bbb)
                bbb(j, 0) = Cells(j + 1, 6) 'Номер2
                bbb(j, 1) = Cells(j + 1, 7) 'Дата2
                bbb(j, 2) = Cells(j + 1, 8) 'Условие2
    Next
        
For y = 0 To UBound(aaa)
    For x = 0 To UBound(bbb)
        If InStr(bbb(y, 2), "IA") Then
            'если номер и дата совпадают
            LastRow_1 = Cells(Rows.Count, 1).End(xlUp).Row
            If bbb(x, 0) = aaa(y, 0) And bbb(x, 1) = aaa(y, 1) Then
                Cells(y + 1, 2).Font.Color = RGB(0, 0, 255)
            ElseIf bbb(x, 0) = aaa(y, 0) And bbb(x, 1) <> aaa(y, 1) Then
                Cells(y + 1, 2).Value = bbb(x, 1)
                Cells(y + 1, 2).Font.Color = RGB(255, 0, 0)
            End If
         End If
    Next
Next
End Sub

Sub Find_Replace()
Set Cur_range = Application.Selection
Replace_Choose.Show 0

Ar_rb = Array(Val_rb1, Val_rb2, Val_rb3, Val_rb4, Val_rb5)
Ar_ra = Array(Val_ra1, Val_ra2, Val_ra3, Val_ra4, Val_ra5)
For Lr = 0 To 4
        Dat_rb = Ar_rb(Lr)
        Dat_ra = Ar_ra(Lr)
    If Dat_rb <> "" Or Dat_ra <> "" Then
Cur_range.Replace Dat_rb, Dat_ra, 2
End If
Next Lr
End Sub

Private Sub CommandButton_Add_Click()Val_rb1 = Rep_before1.Value
Val_rb2 = Rep_before2.Value

*******

Val_ra4 = Rep_after4.Value
Val_ra5 = Rep_after5.Value
    Me.Hide
End Sub

Ar_rb = Array(Val_rb1, Val_rb2, Val_rb3, Val_rb4, Val_rb5)

Sub Workbook_SheetChang
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Application.Interactive = False
Application.ShowWindowsInTaskbar = False

****

end Sub

Sub DateName(Target As Range, KeyCells As Range)
    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        Target.Offset(0, 2).Value = Date
        Target.Offset(0, 3).Value = Application.UserName
        Target.Offset(0, 4).Value = Time
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
'столбец куда вносятся изменения
    Col_tag = Range("A1:AM5").Find("STATUS", , xlValues, xlWhole).Column
'столбец куда "вставляется" имя пользователя, чтобы потом его поменять
    Col_Sig = Range("A1:AM5").Find("Signature", , xlValues, xlWhole).Column
    lLastRow = Cells(Rows.Count, Col_tag).End(xlUp).Row
'при изменении столбца Col_tag, записываем дату, имя пользователя и время 
    DateName Target, Range(Cells(5, Col_tag), Cells(lLastRow, Col_tag))
'далее, для удобства идет переименование "имени пользователя" в реальное имя сотрудника
'для примера две замены, по факту их более 20
Range(Cells(5, Col_Sig), Cells(lLastRow, Col_Sig)).Replace What:="PC_USER1", Replacement:="IVAN IVANOV", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
Range(Cells(5, Col_Sig), Cells(lLastRow, Col_Sig)).Replace What:="PC_USER2", Replacement:="PETR PETROV", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False