=ИНДЕКС($E$21:$E$25;СТОЛБЕЦ(A1))*ИНДЕКС($E$14:$E$18;СТОЛБЕЦ(A1))/ИНДЕКС($E$14:$E$18;СТРОКА(A1))

Sub EditHyperlinks()
    Dim gg As Range, hl As Hyperlink
    For Each gg In Intersect(ActiveSheet.UsedRange, Range("G:G")).Cells
        If gg.Hyperlinks.Count > 0 Then
            gg.Hyperlinks(1).TextToDisplay = gg.EntireRow.Columns("K:K").Value
        End If
    Next
End Sub

=ТЕКСТ(A2;"ММММ")

=СЧЁТЕСЛИМН($B:$B;$F3;$C:$C;G$2)

=ПРОМЕЖУТОЧНЫЕ.ИТОГИ(1;СМЕЩ(RC37;-(14-ПОИСКПОЗ("*";RC2:R[13]C2;0));0;13;1))

=ЕСЛИ(RC[1]=0;ПРОМЕЖУТОЧНЫЕ.ИТОГИ(1;СМЕЩ(RC22;-(14-ПОИСКПОЗ("*";RC2:R[13]C2;0));0;13;1));RC[1]*R1C20-RC[-4])

=ЕСЛИ(ЕПУСТО(RC[-18]);RC[2]*R1C20-RC[-3];СУММ(R[1]C:R[13]C))

Option Explicit

Sub DynaComments()
    Dim cl As Range
    For Each cl In Range("B4:E4").Cells
        FillValidation targetCell:=cl.Cells(4, 1), dateCell:=cl, checkColumn1:=Range("G4:G11"), checkColumn2:=Range("H4:H11"), valueColumn:=Range("I4:I11")
    Next
End Sub

Private Sub FillValidation(targetCell As Range, dateCell As Range, checkColumn1 As Range, checkColumn2 As Range, valueColumn As Range)
    Dim arr As Variant
    arr = GetArr(dateCell:=dateCell, checkColumn1:=checkColumn1, checkColumn2:=checkColumn2, valueColumn:=valueColumn)
    
    With targetCell.Validation
        .Delete
        If Not IsEmpty(arr) Then
            .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
            .IgnoreBlank = True
            .InCellDropdown = False
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = Join(arr, Chr(10))
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub

Private Function GetArr(dateCell As Range, checkColumn1 As Range, checkColumn2 As Range, valueColumn As Range) As Variant
    Dim aVal As Variant, aCh1 As Variant, aCh2 As Variant
    aVal = valueColumn.Value
    aCh1 = checkColumn1.Resize(UBound(aVal, 1), 1).Value
    aCh2 = checkColumn2.Resize(UBound(aVal, 1), 1).Value
    
    Dim arr As Variant, ya As Long
    ReDim arr(1 To UBound(aVal, 1))
    ya = LBound(arr) - 1
    
    Dim dt As Variant
    dt = dateCell.Value
    
    Dim yv As Long
    For yv = 1 To UBound(aVal, 1)
        If aCh1(yv, 1) = dt Then
            GoTo fillRow
        ElseIf aCh2(yv, 1) = dt Then
            GoTo fillRow
        End If
        GoTo skipRow
fillRow:
        ya = ya + 1
        arr(ya) = aVal(yv, 1)
skipRow:
    Next
    If ya < LBound(arr) Then Exit Function
    ReDim Preserve arr(LBound(arr) To ya)
    
    GetArr = arr
End Function

=ЕСЛИ(ИЛИ($G4=B$4;$H4=B$4;);$I4&" ";"")&J5

=СЖПРОБЕЛЫ(J4)

Option Explicit

Sub Собрать()
    CloseEmptyWb
    Dim wbSource As Workbook
    Set wbSource = ActiveWorkbook
    
    Dim wbTarget As Workbook
    Set wbTarget = Workbooks.Add(1)
    
    Dim sh As Worksheet
    For Each sh In wbSource.Worksheets
        If sh.Range("B1").Value = "Дата" Then
            CopySheet sh, wbTarget.Sheets(1)
        End If
    Next
    
    MakeSumSheet wbTarget
    
    wbTarget.Saved = True
End Sub

Private Sub MakeSumSheet(wb As Workbook)
    wb.Sheets(1).Copy After:=wb.Sheets(1)
    Dim sh As Worksheet
    Set sh = wb.Sheets(2)
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=sh.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange sh.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim ya As Long
    For ya = 2 To sh.UsedRange.Rows.Count
        If IsNumeric(sh.UsedRange.Cells(ya, 1).Text) Then
            sh.UsedRange.Cells(ya, 1).Value = WorksheetFunction.RoundDown(sh.UsedRange.Cells(ya, 1).Value, 1)
        End If
    Next
    
    sh.Columns(2).Delete
    sh.UsedRange.RemoveDuplicates Columns:=Array(1), Header:=xlYes
    
    Dim arr As Variant
    ReDim arr(1 To 1, 1 To 12)
    For ya = 1 To UBound(arr, 2)
        arr(1, ya) = DateSerial(Year(Date), ya, 1)
    Next
    With sh.Cells(1, 2).Resize(1, UBound(arr, 2))
        .Value = arr
        .NumberFormat = "mmm-yy"
        .Font.Bold = True
    End With
    
    With sh.Cells(2, 2).Resize(sh.UsedRange.Rows.Count - 1, UBound(arr, 2))
        .FormulaR1C1 = "=COUNTIFS('" & wb.Sheets(1).Name & "'!C2,"">=""&R1C,'" & wb.Sheets(1).Name & "'!C2,""<=""&EOMONTH(R1C,0),'" & wb.Sheets(1).Name & "'!C1,"">=""&RC1,'" & wb.Sheets(1).Name & "'!C1,""<""&R[1]C1)"
        .Rows(.Rows.Count).FormulaR1C1 = "=COUNTIFS('" & wb.Sheets(1).Name & "'!C2,"">=""&R1C,'" & wb.Sheets(1).Name & "'!C2,""<=""&EOMONTH(R1C,0),'" & wb.Sheets(1).Name & "'!C1,"">=""&RC1)"
        .HorizontalAlignment = xlCenter
        
        .FormatConditions.Add Type:=xlExpression, Formula1:="=B2=0"
        .FormatConditions(1).SetFirstPriority
        With .FormatConditions(1).Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Private Sub CopySheet(shSource As Worksheet, shTarget As Worksheet)
    Dim yt As Long
    yt = shTarget.Cells(Rows.Count, 1).End(xlUp).Row
    If yt = 1 Then
        shSource.UsedRange.Copy shTarget.Cells(1, 1)
        shTarget.UsedRange.EntireColumn.AutoFit
    Else
        shSource.UsedRange.Offset(1, 0).Copy shTarget.Cells(yt, 1)
    End If
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Sub Rename_File()
    Dim objFSO As Object, objFile As Object, objFolder As Object
    Dim sFileName, sNewFileName, OldName, NewName
     
    Set objFSO = CreateObject("Scripting.FileSystemObject")
     
    sNewFileName = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp)).Resize(, 2)
    sFileName = Cells(2, 1).Resize(UBound(sNewFileName, 1))
    
    Dim pDialog As Object
    Set pDialog = Application.FileDialog(msoFileDialogFolderPicker)
 
    With pDialog
        .Title = "Выбрать папку с файлами" '"заголовок окна диалога
        .ButtonName = "Выбрать папку"
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .InitialFileName = ActiveWorkbook.Path 'ThisWorkbook.Path '"назначаем первую папку отображения
        .InitialView = msoFileDialogViewLargeIcons 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Sub 'показывает диалог
    End With
     
    Set objFolder = objFSO.GetFolder(pDialog.SelectedItems(1))
    Dim sPath As String
    sPath = objFolder.Path
           
    Dim vFile As Variant, i As Long
    For Each vFile In objFolder.Files
        For i = 1 To UBound(sFileName, 1)
                If LCase(objFSO.getbasename(vFile)) Like LCase(sFileName(i, 1)) Then
                 
'                    OldName = vFile   'старое имя в ячейке
'                    NewName = sPath & "\" & sNewFileName(i, 1)  'новое имя
     
                    Set objFile = objFSO.GetFile(vFile)
                    objFile.Name = sNewFileName(i, 1) & "." & objFSO.GetExtensionName(vFile)
     
'                    Name OldName As NewName
        
                End If
         Next i
      Next
       
End Sub

Set range1 = range2 'создаст ссылку на объект

range1 = range2 'присвоит только значение(или массив значений) без создания ссылки на объект

=ЕСЛИ(СЧЁТЕСЛИМН(Основная!B:B;[@[Названия строк]]);СУММ(D3:D72);ЕСЛИ([@[Количество по полю Замечание]]>0;1;""))

Sub Сумма_с_условием()
    FillSumFormulas Range("D:D")
End Sub

Private Sub FillSumFormulas(rTarget As Range)
    Set rTarget = Intersect(rTarget, rTarget.ListObject.DataBodyRange)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim yr As Long, yp As Long
    For yr = rTarget.Rows.Count To 1 Step -1
        If WorksheetFunction.CountIfs(Sheets("Основная").Columns(2), rTarget.Cells(yr, 1).EntireRow.Cells(1, 1).Value) > 0 Then
            If yp > 0 Then
                rTarget.Cells(yr, 1).FormulaR1C1 = "=SUM(R[1]C:R[" & yp & "]C)"
                yp = 0
            End If
        Else
            rTarget.Cells(yr, 1).FormulaR1C1 = "=IF([@[Количество по полю Замечание]]>0,1,"""")"
            yp = yp + 1
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Option Explicit

Sub Выпадающий_список()
    myFillValidation ActiveSheet, ActiveSheet.Range("I4:K8")
End Sub

Private Sub myFillValidation(sh As Worksheet, validationRange As Range)
    Dim dic As Object
    Set dic = GetDic(validationRange)
    
    Dim cl As Range
    For Each cl In sh.UsedRange.Cells
        If cl.Column > sh.UsedRange.Column Then
            If Intersect(cl, validationRange.Resize(, validationRange.Columns.Count + 1)) Is Nothing Then
                If Not dic.Exists(cl.Value) Then
                    If dic.Exists(cl.Cells(1, 0).Value) Then
                        If cl.Column > sh.UsedRange.Column + 1 Then
                            If Not dic.Exists(cl.Cells(1, -1).Value) Then
                                GoTo fillCellVal
                            End If
                        Else
                            GoTo fillCellVal
                        End If
                    End If
                    cl.Validation.Delete
                    GoTo fillCellEnd
fillCellVal:
    With cl.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dic(cl.Cells(1, 0).Value)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
fillCellEnd:
                End If
            End If
        End If
    Next
End Sub

Private Function GetDic(validationRange As Range) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    arr = validationRange.Value
    
    Dim xa As Long, ya As Long
    For xa = 1 To UBound(arr, 2)
        If Not IsEmpty(arr(1, xa)) Then
            For ya = 2 To UBound(arr, 1)
                If Not IsEmpty(arr(ya, xa)) Then
                    dic(arr(1, xa)) = dic(arr(1, xa)) & arr(ya, xa) & ","
                End If
            Next
        End If
    Next
    
    Dim ss As String
    For ya = 0 To dic.Count - 1
        ss = dic.Items()(ya)
        ss = Left(ss, Len(ss) - 1)
        dic(dic.Keys()(ya)) = ss
    Next
    Set GetDic = dic
End Function

=СУММЕСЛИ($B$3:$B$51;основной!B16;СМЕЩ($J$3:$J$51;0;3*(СТРОКА(A1)-1)))

=СУММ(($A$3:$A$9=$O18)*($B$1:$AM$1>=P$17)*($B$1:$AM$1<=КОНМЕСЯЦА(P$17;0))*$B$3:$AM$9)

'Вместо        
col_str = WorksheetFunction.CountA(.Range("A1:A1000000"))
'Напишите
col_str = .Cells(.Rows.Count, 1).End(xlUp).Row

Option Explicit
Private targetWorkbook As Workbook

Sub Cлисто() 'Это наречие?
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    CloseEmptyWb
    Set targetWorkbook = Workbooks.Add(1)
    
    Dim vFile As Variant, wb As Workbook
    For Each vFile In aFiles
        Set wb = Workbooks.Open(vFile, False, True)
        If Not wb Is Nothing Then
            wb.Sheets.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
            wb.Close False
            Set wb = Nothing
        End If
    Next
    
    CopyFromSheets
    
    Application.Calculation = Application_Calculation
    targetWorkbook.Saved = True
End Sub

Private Sub CopyFromSheets()
    Dim ish As Long, targetRange As Range
    Set targetRange = targetWorkbook.Sheets(1).Cells(1, 1)
    For ish = 2 To targetWorkbook.Sheets.Count
        CopyFromSheet targetWorkbook.Sheets(ish), targetRange
    Next
End Sub

Private Sub CopyFromSheet(shSource As Worksheet, targetRange As Range)
    If shSource.UsedRange Is Nothing Then Exit Sub
    If shSource.UsedRange.Cells.CountLarge = 1 Then Exit Sub
    
    Dim aSource As Variant, ys As Long
    aSource = shSource.UsedRange.Value
    For ys = 1 To UBound(aSource, 1)
        If Not IsError(aSource(ys, 1)) Then
            If Not IsEmpty(aSource(ys, 1)) Then
                If aSource(ys, 1) Like "#*" Then
                    If aSource(ys, 2) = 2 Then
                        If targetRange.EntireColumn.Cells(1, 2).Value <> 2 Then
                            GoTo copyRange
                        Else
                            GoTo exitCopyRange
                        End If
                    Else
                        GoTo copyRange
                    End If
                    
copyRange:
                        Set targetRange = targetRange.Cells(1, 1).Resize(1, shSource.UsedRange.Columns.Count)
                        Application.Goto targetRange
                        shSource.UsedRange.Rows(ys).Copy targetRange
                        targetRange.Cells(1, targetRange.Columns.Count + 1).Value = shSource.Name
                        Set targetRange = targetRange.Cells(2, 1)
exitCopyRange:
                End If
            End If
        End If
    Next
End Sub

Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim sInitialFileName As String
    sInitialFileName = ThisWorkbook.Path & "\"
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim oFD As FileDialog
    Dim lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = sInitialFileName
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant, sName As String
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            sName = fso.GetFileName(.SelectedItems(lf))
            If Left(sName, 2) <> "~$" Then
                If sName <> ThisWorkbook.Name Then
                    If IsEmpty(arr) Then
                        ReDim arr(1 To 1)
                    Else
                        ReDim Preserve arr(1 To UBound(arr) + 1)
                    End If
                    arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
                End If
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit

Function СРЗНАЧР(искомое_значение As Variant, просматриваемый_массив As Range, столбец As Long) As Double
    СРЗНАЧР = WorksheetFunction.Average(Range(ВПРАДРЕС(искомое_значение, просматриваемый_массив, столбец)))
End Function

Function ВПРАДРЕС(искомое_значение As Variant, просматриваемый_массив As Range, столбец As Long) As String
    Set просматриваемый_массив = Intersect(просматриваемый_массив.Columns(1), просматриваемый_массив.Parent.UsedRange)
    Dim arr As Variant
    arr = просматриваемый_массив.Value
    
    Dim vv As Variant, ya As Long
    For Each vv In Split(искомое_значение, ";")
        vv = Trim(vv)
        For ya = 1 To UBound(arr, 1)
            If arr(ya, 1) Like (vv & "*") Then
                ВПРАДРЕС = ВПРАДРЕС & просматриваемый_массив.Cells(ya, столбец).Address(0, 0, xlA1) & ","
            End If
        Next
    Next
    If Right(ВПРАДРЕС, 1) = "," Then ВПРАДРЕС = Left(ВПРАДРЕС, Len(ВПРАДРЕС) - 1)
End Function

=B1<$A1

Option Explicit

Sub Создать_заголовки()
    CloseEmptyWb
    Dim ActiveWindow_Zoom As Long
    ActiveWindow_Zoom = ActiveWindow.Zoom
    
    CreateHeader sourceRange:=Selection, headerColumn:=1, targetRange:=Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    ActiveWindow.Zoom = ActiveWindow_Zoom
End Sub

Private Sub CreateHeader(sourceRange As Range, headerColumn As Long, targetRange As Range)
    Set sourceRange = Intersect(sourceRange, sourceRange.Parent.UsedRange)
    Set targetRange = targetRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    sourceRange.Copy targetRange
    sourceRange.Copy
    targetRange.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    Dim yt As Long
    For yt = targetRange.Rows.Count To 2 Step -1
        If targetRange.Cells(yt, headerColumn).Value <> targetRange.Cells(yt - 1, headerColumn).Value Then
            targetRange.Cells(yt, 1).Select
            targetRange.Cells(yt, 1).EntireRow.Insert
            targetRange.Cells(yt, headerColumn + 1).Value = targetRange.Cells(yt + 1, headerColumn).Value
        End If
    Next
    targetRange.Cells(yt + 1, headerColumn).Resize(targetRange.Rows.Count, 1).ClearContents
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit

Sub SplitTables()
    SplitRange Selection
End Sub

Private Sub SplitRange(sourceRange As Range)
    On Error Resume Next
    Set sourceRange = Intersect(sourceRange, sourceRange.Parent.UsedRange)
    On Error GoTo 0
    If sourceRange Is Nothing Then Exit Sub
    
    Dim dic As Object
    Set dic = GetHeaderDic(sourceRange.Rows(1))
    If dic Is Nothing Then Exit Sub
    If dic.Count = 0 Then Exit Sub
    
    Dim targetRange As Range
    Set targetRange = sourceRange.CurrentRegion.Cells(1, sourceRange.CurrentRegion.Columns.Count + 3)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim vHeader As Variant
    For Each vHeader In dic.Keys
        CopyHeader vHeader, sourceRange, targetRange
        Set targetRange = targetRange.Cells(1 + sourceRange.Rows.Count + 5, 1)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CopyHeader(ByVal sHeader As String, sourceRange As Range, targetRange As Range)
    Set targetRange = targetRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
    targetRange.Clear
    
    Dim aSource As Variant, xs As Long, ys As Long
    aSource = sourceRange.Value
    
    Dim xt As Long
    For xs = 2 To UBound(aSource, 2)
        If aSource(1, xs) = sHeader Then
            CopyOneColumn sourceRange, xs, targetRange, xt
        End If
    Next

    If sourceRange.Columns.Count > 2 Then
        Application.DisplayAlerts = False
        targetRange.Cells(1, 2).Resize(1, xt).Merge
        Application.DisplayAlerts = True
    End If

End Sub

Private Sub CopyOneColumn(sourceRange As Range, xs As Long, targetRange As Range, ByRef xt As Long)
    xt = xt + 1
    If xt = 1 Then
        sourceRange.Columns(1).Copy targetRange.Columns(1)
    End If
     
    sourceRange.Columns(xs).Copy targetRange.Columns(1 + xt)
End Sub

Private Function GetHeaderDic(sourceRange As Range) As Object
    If sourceRange.Columns.Count = 1 Then Exit Function
    Dim aSource As Variant, xs As Long
    aSource = sourceRange.Value
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For xs = 2 To UBound(aSource, 2)
        If Not IsEmpty(aSource(1, xs)) Then
            dic(aSource(1, xs)) = Empty
        End If
    Next
    
    Set GetHeaderDic = dic
End Function

Sub Продублировать()
    Workbooks("Книга1").Sheets(1).Range("A1").Value = Workbooks("Книга2").Sheets(1).Range("B2").Value
    Workbooks("Книга1").Sheets(1).Range("A2").Value = Workbooks("Книга2").Sheets(1).Range("B3").Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Продублировать
End Sub