Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Column > 1 Then
            If IsEmpty(Target.Offset(0, -1)) Then
                MsgBox "Якась зрада", vbInformation
            End If
        End If
    End If
End Sub

ActiveSheet.Shapes(1).Chart.SetSourceData Source:=Range(Cells(1, 1).CurrentRegion.Address)

Sub ActiveCellAutoFit()
    myAutoFit ActiveCell
End Sub

Sub SelectionAutoFit()
    Dim rn As Range
    On Error Resume Next
        Set rn = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    
    If Not rn Is Nothing Then
        Dim cl As Range
        For Each cl In rn
            myAutoFit cl
        Next
    End If
End Sub

Sub myAutoFit(cl As Range)
    Dim arr As Variant
    arr = Split(cl.Value, " ")
    
    If UBound(arr) > -0 Then
        Dim r As Range
        Set r = cl.Cells(1).Resize(UBound(arr) + 1)
        
        Dim brr As Variant
        brr = r.Formula
        
        r = Application.Transpose(arr)
        r.WrapText = False
        r.EntireColumn.AutoFit
        
        r.Formula = brr
        r.WrapText = True
    End If
End Sub

Private Sub Worksheet_Activate()
    Dim x As Byte
    Dim arr As Variant
    Dim col As Variant
    For Each col In Array("A", "C", "Z", "AA")
        arr = Sheets(1).UsedRange.Columns(col)
        x = x + 1
        Cells(1, x).Resize(UBound(arr, 1), 1) = arr
    Next
End Sub

=СЧЁТЕСЛИМН(N:N;">6")
=СЧЁТЕСЛИМН(N:N;"<4")

Sub FotoFoto()
    Dim ar1 As Variant: ar1 = Sheets("Лист1").Range("A1:M5")
    Dim ar2 As Variant: ar2 = Sheets("Лист1").Range("O1:Q11")
     
    Dim y1 As Long
    Dim y2 As Long
    Dim x As Integer
    For y2 = 2 To UBound(ar2, 1)
        If Not IsEmpty(ar2(y2, 1)) Then
            For y1 = 2 To UBound(ar1, 1)
                If Not IsEmpty(ar1(y1, 1)) Then
                    If ar2(y2, 1) = ar1(y1, 1) Then
                        If ar2(y2, 3) >= ar1(y1, 2) Then
                            If ar2(y2, 3) <= ar1(y1, 3) Then
                                For x = 4 To UBound(ar1, 2) Step 2
                                    If IsEmpty(ar1(y1, x)) Then
                                        ar1(y1, x + 0) = ar2(y2, 2)
                                        ar1(y1, x + 1) = ar2(y2, 3)
                                        y1 = UBound(ar1, 1)
                                        Exit For
                                    End If
                                Next
                            End If
                        End If
                    End If
                End If
            Next
        End If
    Next
     
    Sheets("Лист1").Range("A1").Resize(UBound(ar1, 1), UBound(ar1, 2)) = ar1
End Sub

Sub FotoFoto()
    Dim ar1 As Variant: ar1 = Sheets("Лист1").Range("A1:H5")
    Dim ar2 As Variant: ar2 = Sheets("Лист1").Range("K1:M11")
    
    Dim y1 As Long
    Dim y2 As Long
    Dim x As Integer
    For y2 = 2 To UBound(ar2, 1)
        For y1 = 2 To UBound(ar1, 1)
            If ar2(y2, 1) = ar1(y1, 1) Then
                If ar2(y2, 3) >= ar1(y1, 2) Then
                    If ar2(y2, 3) <= ar1(y1, 3) Then
                        For x = 4 To UBound(ar1, 2)
                            If IsEmpty(ar1(y1, x)) Then
                                ar1(y1, x) = ar2(y2, 2)
                                y1 = UBound(ar1, 1)
                                Exit For
                            End If
                        Next
                    End If
                End If
            End If
        Next
    Next
    
    Sheets("Лист1").Range("A1").Resize(UBound(ar1, 1), UBound(ar1, 2)) = ar1
End Sub

=ЕСЛИОШИБКА(ИНДЕКС($L$1:$L$11;НАИБОЛЬШИЙ(($A2=$K$2:$K$11)*($B2<=$M$2:$M$11)*($C2>=$M$2:$M$11)*СТРОКА($K$2:$K$11);СТОЛБЕЦ(A:A)));"")

=ЕСЛИОШИБКА(ЕСЛИ(ЕОШ(НАЙТИ(" мин, ";B11));ЗНАЧЕН(ПОДСТАВИТЬ(ПОДСТАВИТЬ(B11;"сек";"");" ";""));ЗНАЧЕН(ПСТР(B11;1;НАЙТИ(" мин, ";B11)))*60+ЗНАЧЕН(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПСТР(B11;НАЙТИ(" мин, ";B11)+6;ДЛСТР(B11));"сек";"");" ";"")));0)

Option Explicit

Dim dic As Object

Sub FillNearSelection()
    Selection.Cells(1, 2).Value = myFunc(Selection.Cells(1, 1))
End Sub

Function myFunc(Ячейка As Range) As String
    InitDic
    Dim s As String
    Dim t As String
    s = Ячейка.Cells(1).Value
    
    Dim di2 As Object
    Dim arr As Variant
    Dim brr As Variant
    Dim v As Variant
    Dim i As Long
    For Each v In dic.Keys()
        If InStr(s, v) > 0 Then
            Set di2 = dic.Item(v)
            arr = di2.Keys()
            For i = LBound(arr) To UBound(arr)
                arr(i) = Replace(s, v, arr(i))
            Next
            s = Join(arr, vbCrLf)
        End If
    Next
    myFunc = s
End Function

Sub ClearCache()
    Set dic = Nothing
End Sub

Sub InitDic()
    If dic Is Nothing Then
        Set dic = CreateObject("Scripting.Dictionary")
        
        Dim v As Variant
        For Each v In Array("[B]", "[E]", "[M]", "[S]", "[V]", "[X]", "[Y]")
            Set dic.Item(v) = CreateObject("Scripting.Dictionary")
        Next
        
        dic.Item("[B]").Item("B") = 0
        dic.Item("[B]").Item("A") = 0
        dic.Item("[B]").Item("M") = 0
        dic.Item("[B]").Item("S") = 0
        dic.Item("[E]").Item("A") = 0
        dic.Item("[E]").Item("B") = 0
        dic.Item("[E]").Item("C") = 0
        dic.Item("[M]").Item("B") = 0
        dic.Item("[M]").Item("N") = 0
        dic.Item("[M]").Item("S") = 0
        dic.Item("[S]").Item("1") = 0
        dic.Item("[S]").Item("2") = 0
        dic.Item("[S]").Item("3") = 0
        dic.Item("[S]").Item("4") = 0
        dic.Item("[V]").Item("A1") = 0
        dic.Item("[V]").Item("D1") = 0
        dic.Item("[X]").Item("G") = 0
        dic.Item("[X]").Item("R") = 0
        dic.Item("[Y]").Item("A") = 0
        dic.Item("[Y]").Item("B") = 0
        dic.Item("[Y]").Item("C") = 0
        dic.Item("[Y]").Item("G") = 0
        dic.Item("[Y]").Item("M") = 0
        dic.Item("[Y]").Item("R") = 0
        dic.Item("[Y]").Item("Y") = 0
        
    End If
End Sub

Sub myFilter()
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim param As Variant
    param = Split(Cells(1, 3).Value, ",")
    
    Dim arr As Variant
    Dim y As Long
    y = Cells(Rows.Count, 2).End(xlUp).Row
    arr = Range(Cells(1, 2), Cells(y, 2 - (y = 1)))
    
    Dim v As Variant
    For y = 2 To UBound(arr, 1)
        For Each v In param
            If arr(y, 1) = v Then
                Rows(y).Hidden = True
                Exit For
            End If
        Next
    Next
End Sub

=ВПР(B2;E:F;2;1)

=СМЕЩ($A$1;СТРОКА()-(СТРОКА()>СЧЁТЗ(A:A))*СЧЁТЗ(A:A)-(СТРОКА()>СЧЁТЗ(A:B))*СЧЁТЗ(B:B)-(СТРОКА()>СЧЁТЗ(A:C))*СЧЁТЗ(C:C)-(СТРОКА()>СЧЁТЗ(A:D))*СЧЁТЗ(D:D)-1;(СТРОКА()>СЧЁТЗ(A:A))+(СТРОКА()>СЧЁТЗ(A:B))+(СТРОКА()>СЧЁТЗ(A:C))+(СТРОКА()>СЧЁТЗ(A:D)))

=(A1>=0,75)*0,5+(A1>0,8)*0,1-(A1>0,85)*0,6
=ЕСЛИ(A1>=0,75;ЕСЛИ(A1>0,8;ЕСЛИ(A1>0,85;0;0,6);0,5);0)

=МАКС(ЕСЛИОШИБКА(НАЙТИ($A15;B$3:B$11);0))>0
=МИН(2;СУММ((ЕСЛИОШИБКА(НАЙТИ($A15;B$3:B$11);0)>0)*1))

=МИН(СМЕЩ(C8;0;0;СУММ((ЛЕВСИМВ(A8:$A$56;ДЛСТР(A7))=A7)*1);1))
=МАКС(СМЕЩ(D8;0;0;СУММ((ЛЕВСИМВ(A8:$A$56;ДЛСТР(A7))=A7)*1);1))

=СМЕЩ(ДВССЫЛ("'"&$B$1&"'!A1");СТРОКА()-1;0)

Sub Разнести()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Лист1")
     
    Dim arr As Variant
    Dim brr As Variant
    Dim bbr As Variant
    Dim orr As Variant
    Dim y As Long
    Dim x As Integer
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 5))
        ReDim orr(1 To y, 1 To 1)
    End With
     
    Dim dic As Object
    Dim dicU As Object
    Set dicU = CreateObject("Scripting.Dictionary")
     
    Dim shA As Worksheet
    Dim u As Long
    For y = 5 To UBound(arr, 1)
        If arr(y, 1) = 1 Then
            Set shA = Nothing
            On Error Resume Next
            Set shA = Worksheets(arr(y, 2))
            On Error GoTo 0
            If shA Is Nothing Then
                orr(y, 1) = "нет листа"
            Else
                If Not dicU.Exists(arr(y, 2)) Then
                    Set dicU.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    With shA
                        x = arr(y, 3)
'                        On Error Resume Next
'                        x = WorksheetFunction.Match("Значение", .Rows(4), 0)
'                        On Error GoTo 0
                    
                        u = .Cells(.Rows.Count, 1).End(xlUp).Row
                        brr = .Range(.Cells(1, 1), .Cells(u, 1 - (u = 1)))
                        ReDim bbr(1 To u, 1 To 1)
                        bbr(4, 1) = "Значение"
                    End With
                    dicU.Item(arr(y, 2)).Item("array") = bbr
                    dicU.Item(arr(y, 2)).Item("x") = x
                    For u = 5 To UBound(brr, 1)
                        dicU.Item(arr(y, 2)).Item(brr(u, 1)) = u
                    Next
                End If
             
                Set dic = dicU.Item(arr(y, 2))
                brr = dic.Item("array")
                 
                If dic.Exists(arr(y, 4)) Then
                    u = dic.Item(arr(y, 4))
                Else
                    u = 0
                End If
                 
                If u = 0 Then
                    orr(y, 1) = "нет даты"
                Else
                    brr(u, 1) = arr(y, 5)
                    dicU.Item(arr(y, 2)).Item("array") = brr
                    orr(y, 1) = "ok"
                End If
            End If
        End If
    Next
     
    For y = 0 To dicU.Count - 1
        x = dicU.Items()(y).Item("x")
        If x > 0 Then
            brr = dicU.Items()(y).Item("array")
            Sheets(dicU.Keys()(y)).Cells(1, x).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
        End If
    Next
     
    sh1.Range("F1").Resize(UBound(orr, 1), 1) = orr
End Sub

=СУММ(14:14)/СЧЁТЕСЛИМН(14:14;">0")

Sub Разнести()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Лист1")
    
    Dim arr As Variant
    Dim brr As Variant
    Dim orr As Variant
    Dim y As Long
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 4))
        ReDim orr(1 To y, 1 To 1)
    End With
    
    Dim dic As Object
    Dim dicU As Object
    Set dicU = CreateObject("Scripting.Dictionary")
    
    Dim shA As Worksheet
    Dim u As Long
    For y = 5 To UBound(arr, 1)
        If arr(y, 1) = 1 Then
            Set shA = Nothing
            On Error Resume Next
            Set shA = Worksheets(arr(y, 2))
            On Error GoTo 0
            If shA Is Nothing Then
                orr(y, 1) = "нет листа"
            Else
                If Not dicU.Exists(arr(y, 2)) Then
                    Set dicU.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    With shA
                        u = .Cells(.Rows.Count, 1).End(xlUp).Row
                        brr = .Range(.Cells(1, 1), .Cells(u, 2))
                    End With
                    dicU.Item(arr(y, 2)).Item("array") = brr
                    For u = 5 To UBound(brr, 1)
                        dicU.Item(arr(y, 2)).Item(brr(u, 1)) = u
                    Next
                End If
            
                Set dic = dicU.Item(arr(y, 2))
                brr = dic.Item("array")
                
                If dic.Exists(arr(y, 3)) Then
                    u = dic.Item(arr(y, 3))
                Else
                    u = 0
                End If
                
                If u = 0 Then
                    orr(y, 1) = "нет даты"
                Else
                    'shA.Cells(u, 2).Value = arr(y, 4)
                    brr(u, 2) = arr(y, 4)
                    dicU.Item(arr(y, 2)).Item("array") = brr
                    orr(y, 1) = "ok"
                End If
            End If
        End If
    Next
    
    For y = 0 To dicU.Count - 1
        brr = dicU.Items()(y).Item("array")
        Sheets(dicU.Keys()(y)).Cells(1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    Next
    
    sh1.Range("E1").Resize(UBound(orr, 1), 1) = orr
End Sub

=СУММЕСЛИМН(СМЕЩ(H8:H13;0;ПОИСКПОЗ(I7;H7:J7;0)-1);F8:F13;F13)
=СУММ(мебель*(H7:J7=$I$7)*(F8:F13=$F$13)) формула массива

Sub Разнести()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Лист1")
    
    Dim arr As Variant
    Dim orr As Variant
    Dim y As Long
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 4))
        ReDim orr(1 To y, 1 To 1)
    End With
    
    Dim shA As Worksheet
    Dim u As Long
    For y = 5 To UBound(arr, 1)
        If arr(y, 1) = 1 Then
            Set shA = Nothing
            On Error Resume Next
            Set shA = Worksheets(arr(y, 2))
            On Error GoTo 0
            If shA Is Nothing Then
                orr(y, 1) = "нет листа"
            Else
                u = 0
                On Error Resume Next
                'u = WorksheetFunction.Match(arr(y, 3), shA.Columns(1), 0)
                With sh1.Cells(y, 5)
                    .FormulaR1C1 = "=MATCH(RC3,'" & arr(y, 2) & "'!C1,0)"
                    u = .Value
                    .Clear
                End With
                On Error GoTo 0
                
                If u = 0 Then
                    orr(y, 1) = "нет даты"
                Else
                    shA.Cells(u, 2).Value = arr(y, 4)
                    orr(y, 1) = "ok"
                End If
            End If
        End If
    Next
    sh1.Range("E1").Resize(UBound(orr, 1), 1) = orr
End Sub

=ЕСЛИ(СТРОКА()=МАКС(НЕ(ЕОШ(НАЙТИ(". ";$B$7:B7)))*СТРОКА($B$7:B7));ЛЕВСИМВ(B7;НАЙТИ(". ";B7)-1);
ЛЕВСИМВ(СМЕЩ($B$1;МАКС(НЕ(ЕОШ(НАЙТИ(". ";$B$7:B7)))*СТРОКА($B$7:B7))-1;0);НАЙТИ(". ";СМЕЩ($B$1;МАКС(НЕ(ЕОШ(НАЙТИ(". ";$B$7:B7)))*СТРОКА($B$7:B7))-1;0))-1)&"."&СТРОКА()-МАКС(НЕ(ЕОШ(НАЙТИ(". ";$B$7:B7)))*СТРОКА($B$7:B7)))

F7    =ЕСЛИ(ЕОШ(НАЙТИ(". ";B7));F6;ЛЕВСИМВ(B7;НАЙТИ(". ";B7)-1))
A7    =ЕСЛИ(СЧЁТЕСЛИМН($F$1:F6;F7)=0;F7;F7&"."&СЧЁТЕСЛИМН($F$1:F6;F7))

=(СЧЁТЕСЛИМН($A$1:A2;A3)=0)*ВПР(A3;$G$3:$H$14;2;ЛОЖЬ)

Sub myCopyFolders()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemobject")
    Dim arrFr As Variant: arrFr = Range("A1:A2")
    Dim arrTo As Variant: arrTo = Range("B1:B2")
    
    Dim y As Long
    For y = 1 To UBound(arrFr, 1)
        fso.GetFolder(arrFr(y, 1)).Copy arrTo(y, 1)
    Next
End Sub

Sub CopyToTotal()
    Dim y As Long
    On Error Resume Next
        y = WorksheetFunction.Match([A4].Value, Range("M3:M20"), 0)
    On Error GoTo 0
    If y > 0 Then
        Dim arr As Variant
        arr = Range("B6:B14")
        [N3].Cells(y, 1).Resize(1, UBound(arr, 1)) = Application.Transpose(arr)
    End If
End Sub

Sub myFilter()
    
    Cells.EntireRow.Hidden = False
    
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(ActiveSheet.UsedRange, Selection)
    On Error GoTo 0
    
    With r.Areas(1)
        If .Cells.Count > 1 Then
            Dim arr As Variant
            arr = .Cells
            Dim y As Long
            For y = 1 To UBound(arr, 1)
                If Not IsNumeric(Left(arr(y, 1), 1)) Then
                    .Cells(y, 1).EntireRow.Hidden = True
                End If
            Next
        End If
    End With
End Sub