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

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

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 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

Dim strSourceFile
Dim oShell
Dim objFSO
Dim strLine
Dim TimeSleep
Set oShell = wscript.CreateObject("WScript.Shell")
oShell.Run "telnet.exe"
TimeSleep = 500
wscript.Sleep 2000
strSourceFile = "DATA.txt"
With wscript.CreateObject("Scripting.FileSystemObject")
If .FileExists(strSourceFile) Then
    With .OpenTextFile(strSourceFile)
        Do Until .AtEndOfStream
            strLine = .ReadLine()

oShell.SendKeys "o " & strLine
oShell.SendKeys "{Enter}"
wscript.Sleep TimeSleep

oShell.SendKeys "admin"
oShell.SendKeys "{Enter}"
wscript.Sleep TimeSleep

oShell.SendKeys "admin"
oShell.SendKeys "{Enter}"
wscript.Sleep TimeSleep

oShell.SendKeys "^(S)"
wscript.Sleep TimeSleep

****

oShell.SendKeys "{F}"
oShell.SendKeys "{Enter}"
wscript.Sleep TimeSleep

            Loop
        .Close
    End With
Else
    wscript.echo "Can't find [" & strSourceFile & "]."
    wscript.Quit 1
End If
oShell.SendKeys "{Q}"
oShell.SendKeys "{Enter}"
End With
wscript.echo "Выполнено"

Application.InputBox(Prompt:="Укажите диапазон IP адресов для Сброса Alarms:", Type:=8)

Private Sub Workbook_Open()
On Error Resume Next
'убираем фильтры со всех листов
Dim i&
   For i = 1 To Sheets.Count
       If Sheets(i).FilterMode = True Then Sheets(i).ShowAllData
   Next i
Worksheets("IEC-61850").Activate
        Call Data_List_Status
Worksheets("MODBUS_TCP").Activate
        Call Data_List_Status
Worksheets("SCADA").Activate
        Call Data_List_Status
Worksheets("PMS_LSS").Activate
        Call Data_List_Status
Worksheets("ELSS").Activate
        Call Data_List_Status
Worksheets("Main").Activate
End Sub

Public ESS_num&
Private Sub CheckBox1_Click()
    If CheckBox1.Value = True Then
        ESS_num = Range("B4:B35").Find("CCB-020", , xlValues, xlWhole).Row
        Rows(ESS_num).Select
        Selection.EntireRow.Hidden = True
    Else
        ESS_num = Range("B4:B35").Find("CCB-020", , xlValues, xlWhole).Row
        Rows(ESS_num).Select
        Selection.EntireRow.Hidden = False
    End If
End Sub

=СЧЁТЕСЛИМН(ELSS!G:G;"=*043S030C*";ELSS!Y:Y;"<>*SPARE*")

=СЧЁТЕСЛИМН(#ССЫЛКА!G:G;"=*043S030C*";#ССЫЛКА!Y:Y;"<>*SPARE*")

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Range("A1:A50")
    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
        Target.Offset(0, 2).Value = Date
        Target.Offset(0, 3).Value = Application.UserName
    End If
End Sub

Public List
           With ActiveWorkbook
 On Error GoTo Error1
           Call List_copy ' выполняется Активация User формы, где из сплывающего списка необходимо выбрать название листа, который нужно копировать

           .Sheets(List).Copy before:=BazaWb.Sheets(1)
 GoTo Ends:
 Error1:
 On Error GoTo Error2
            List = InputBox("Данный лист не найден, введите название листа вручную", "IO", "")
            .Sheets(List).Copy before:=BazaWb.Sheets(1)
 GoTo Ends:
 Error2:
 MsgBox ("Дынный лист не найден, проверьте правильность написания и повторите процедуру") Exit Sub '? здесь процедуру заканчивать 
 Ends:
          End With
  
           Workbooks(oAwb).Close False    'Закрываем книгу

10 Dim lLastRow&, lLastCol&
20 lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 'ищем последнюю непустую ячейку в столбце 1
30lLastCol = Cells(5, Columns.Count).End(xlToLeft).Column 'ищем последний непустой ячейку в строке 5

40   Cells.FormatConditions.Delete
50    Range(Cells(5, 1), Cells(lLastRow, lLastCol + 1)).Select
60    Cells(5, lLastCol + 1).Activate
70    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
80     "=$" & Cells(5, lLastCol + 1) & "=""FAIL"""
90    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
100   With Selection.FormatConditions(1).Interior
110        .PatternColorIndex = xlAutomatic
120        .ThemeColor = xlThemeColorAccent6
130        .TintAndShade = 0.399945066682943
140    End With

Public x As String
Public y As String
Sub www()
    x = "A1"
    y = "K5"
   Call qqq
End Sub

Sub qqq()
Cells.Range(x, y).Value = 1
End Sub

Sub ESS_800()
Dim sFilePath As String, sFileName As String, sSh As String
Dim sStr As String
    Worksheets("800").Select
    Range("B5:Y19").Select
    Selection.NumberFormat = "[<>0]General;"
sFilePath = Dir(ThisWorkbook.Path & "*.xlsm")
sFileName = "800.xlsm"
sSh = "Main"
    With Range("B5:Y19")
    .Formula = "='" & sFilePath & "[" & sFileName & "]" & sSh & "'!" & "B5"
    .Value = .Value
    End With
End Sub 

Sub Обновить_значения()    
Call Sheets("001").ESS_001    
Call Sheets("800").ESS_800    
Worksheets("Total").Select
End Sub

  Selection.Replace What:="X", Replacement:="Х", _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
    False, ReplaceFormat:=False
    Selection.Replace What:="T", Replacement:="Т", _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
    False, ReplaceFormat:=False
End Sub

Sub Replace_NOT_DONE()
    Selection.Replace What:="Х", Replacement:="X", _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
    False, ReplaceFormat:=False
    Selection.Replace What:="Т", Replacement:="T", _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
    False, ReplaceFormat:=False
End Sub

Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim n
    With Worksheets("C&E1") '!!!!!!!!!!!!!!!!!!!!!!!!!!!
        Set Rng = Selection
        For Each n In Rng
            Select Case n
                Case "X"
                   n.Interior.Color = RGB(255, 200, 200)
                Case "T"
                    n.Interior.Color = RGB(255, 200, 200)
                Case "Х"
                    n.Interior.Color = RGB(0, 255, 0)
                Case "Т"
                    n.Interior.Color = RGB(0, 255, 0)
            End Select
        Next n
    End With
End Sub