Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        Select Case Target.Address(0, 0)
        Case "C2", "C6"
            If Range("C2").Value <> "" Then
                If Range("C6").Value <> "" Then
                    MoveData
                    Application.EnableEvents = False
                    Range("C2").MergeArea.ClearContents
                    Range("C6").MergeArea.ClearContents
                    Application.EnableEvents = True
                End If
            End If
        End Select
    End If
End Sub

Private Sub MoveData()
    With Sheets("Лист2")
        With .ListObjects(1).DataBodyRange
            With .Rows(.Rows.Count - (.Cells(.Rows.Count, 2).Value <> ""))
                .Cells(1, 2).Value = Range("C2").Value
                .Cells(1, 3).Value = Range("C6").Value
                If .Cells(1, 1).Value = "" Then
                    If IsNumeric(.Cells(1, 1).Offset(-1, 0).Value) Then
                        .Cells(1, 1).Value = .Cells(1, 1).Offset(-1, 0).Value + 1
                    Else
                        .Cells(1, 1).Value = 1
                    End If
                End If
            End With
        End With
    End With
End Sub

Option Explicit

Sub ФильтрТаблиц()
    Dim ar1 As Variant
    ar1 = Sheets("Лист1").Range("A1:B10")
    
    Dim ar2 As Variant
    ar2 = Sheets("Лист2").Range("A1:C10")
    
    Dim dic As Object
    Set dic = GetDic(ar1)
    Erase ar1
    
    Dim arr As Variant
    arr = GetArrResult(dic, ar2)
    
    PrintArr arr
End Sub

Sub PrintArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Value = arr
        End With
        .Saved = True
    End With
End Sub

Function GetArrResult(dic, arr) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    Dim y As Long
    Dim u As Long
    Dim x As Integer
    For x = 1 To UBound(arr, 2)
        brr(1, x) = arr(1, x)
    Next
    u = 1
    For y = 2 To UBound(arr, 1)
        If dic.Exists(arr(y, 1)) Then
            u = u + 1
            For x = 1 To UBound(arr, 2)
                brr(u, x) = arr(y, x)
            Next
        End If
    Next
    Dim crr As Variant
    ReDim crr(1 To u, 1 To UBound(brr, 2))
    For y = 1 To UBound(crr, 1)
        For x = 1 To UBound(crr, 2)
            crr(y, x) = brr(y, x)
        Next
    Next
    GetArrResult = crr
End Function

Function GetDic(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 2 To UBound(arr, 1)
        If arr(y, 2) Then dic.Item(arr(y, 1)) = 0
    Next
    Set GetDic = dic
End Function

Option Explicit
'v5
Sub ReorganizeWithDialog()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
 
    Dim wb As Workbook
    Set wb = ShowFileDialog()
    If Not wb Is Nothing Then
        Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
        Reorganize wb
        wb.Close False
    End If
     
    Application.Calculation = Application_Calculation
End Sub
 
Function ShowFileDialog() As Workbook
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Name 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To 1 '.SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x) 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function
 
Sub Reorganize(wb As Workbook)
     
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
     
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
        SaveWb sh2.Parent, wb
    End If
     
End Sub
 
Sub SaveWb(wb2 As Workbook, wb1 As Workbook)
    Dim newName As String
    newName = GetNewName(wb1.Name)
    newName = wb1.Path & "\" & newName
    On Error Resume Next
    Kill newName
    On Error GoTo 0
    wb2.SaveAs Filename:=newName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'wb2.Close
End Sub

Function GetNewName(ByVal oldName As String) As String
    oldName = Replace(oldName, ".xlsb", ".xlsx")
    oldName = Replace(oldName, ".xlsm", ".xlsx")
    oldName = Replace(oldName, ")", "(")
    Dim arr As Variant
    arr = Split(oldName, "(")
    Dim newName As String
    If UBound(arr) > 0 Then
        If IsNumeric(arr(UBound(arr))) Then
            arr(UBound(arr)) = arr(UBound(arr)) + 1
            arr(UBound(arr)) = "(" & arr(UBound(arr)) & ")"
            newName = Join(arr, "")
        End If
    End If
    If newName = "" Then
        With CreateObject("Scripting.FileSystemObject")
            newName = .GetBaseName(oldName) & " (1).xlsx"
        End With
    End If
    GetNewName = newName
End Function
 
Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    With sh2.PageSetup
        .Orientation = xlPortrait
        .LeftMargin = Application.InchesToPoints(1.96850393700787)
        .RightMargin = Application.InchesToPoints(1.96850393700787)
        .TopMargin = Application.InchesToPoints(1.96850393700787)
        .BottomMargin = Application.InchesToPoints(3.93700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
    End With
     
    Set GetSh2 = sh2
End Function
 
Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub
 
Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                    If x > 4 Then
                        If x < 11 Then
                            If brr(n, x) = "" Then
                                brr(n, x) = "'"
                            End If
                        End If
                    End If
                Next
                 
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                 
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function
 
Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function

Option Explicit
'v4
Sub ReorganizeWithDialog()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim wb As Workbook
    Set wb = ShowFileDialog()
    If Not wb Is Nothing Then
        Application.Dialogs(xlDialogWorkgroup).Show ActiveSheet.Name
        Reorganize
        wb.Close False
    End If
    
    Application.Calculation = Application_Calculation
End Sub

Function ShowFileDialog() As Workbook
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Name 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To 1 '.SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Set ShowFileDialog = Workbooks.Open(x) 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
    End With
End Function

Sub Reorganize()
    
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
    
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
    End If
    
End Sub

Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    
    Set GetSh2 = sh2
End Function

Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                    If x > 4 Then
                        If x < 11 Then
                            If brr(n, x) = "" Then
                                brr(n, x) = "'"
                            End If
                        End If
                    End If
                Next
                
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function

Option Explicit
'v3
Sub Reorganize()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = ActiveSheet
    Dim arr As Variant
    arr = GetArr(sh1)
    Set sh2 = GetSh2(sh1)
    
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr, sh1, sh2)
    If Not IsEmpty(frr) Then
        OutArr frr, sh2
    End If
    
    Application.Calculation = Application_Calculation
End Sub

Function GetSh2(sh1 As Worksheet) As Worksheet
    Dim sh2 As Worksheet
    sh1.Copy
    Set sh2 = ActiveSheet
    sh2.Cells.Clear
    
    Set GetSh2 = sh2
End Function

Sub OutArr(arr As Variant, sh2 As Worksheet)
    'With Workbooks.Add(1)
    With sh2.Parent
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant, sh1 As Worksheet, sh2 As Worksheet) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                    If x > 4 Then
                        If x < 11 Then
                            If brr(n, x) = "" Then
                                brr(n, x) = "'"
                            End If
                        End If
                    End If
                Next
                
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 11)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
                    End If
                End If
                
                sh1.Rows(y).Copy sh2.Cells(n, 1)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                If IsNumeric(brr(yOZ, 11)) Then
                    If IsNumeric(arr(y, 10)) Then
                        brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                    End If
                End If
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function

Option Explicit
'v2
Sub Reorganize()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr)
    If Not IsEmpty(frr) Then
        OutArr frr
    End If
End Sub

Sub OutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        Dim yOZ As Long
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                Next
                
                If yOZ = 0 Then
                    yOZ = n
                    'brr(yOZ, 11) = 0
                End If
                brr(yOZ, 11) = brr(yOZ, 11) - arr(y, 11)
            End If
            If arr(y, 3) = "Общие затраты:" Then
                brr(yOZ, 11) = brr(yOZ, 11) + arr(y, 10)
                yOZ = 0
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp).Cells(1, 11 - 2))
    End With
End Function

Option Explicit

Sub Reorganize()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    Dim frr As Variant
    frr = GetNoEmptyRowArr(arr)
    If Not IsEmpty(frr) Then
        OutArr frr
    End If
End Sub

Sub OutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetNoEmptyRowArr(arr As Variant) As Variant
    Dim y As Long
    Dim n As Long
    For y = 3 To UBound(arr, 1)
        n = n + 1 + IsEmpty(arr(y, 1))
    Next
    If n > 0 Then
        Dim brr As Variant
        ReDim brr(1 To n, 1 To UBound(arr, 2))
        Dim x As Integer
        n = 0
        For y = 3 To UBound(arr, 1)
            If Not IsEmpty(arr(y, 1)) Then
                n = n + 1
                For x = 1 To UBound(arr, 2)
                    brr(n, x) = arr(y, x)
                Next
            End If
        Next
        GetNoEmptyRowArr = brr
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 11))
    End With
End Function

Реестр!G6           =ЕСЛИОШИБКА(СМЕЩ(Снаб!G$1;ПОИСКПОЗ(СТРОКА(1:1);Снаб!$O:$O;0)-1;0)&"/"&СМЕЩ(Снаб!H$1;ПОИСКПОЗ(СТРОКА(1:1);Снаб!$O:$O;0)-1;0)&"/"&СМЕЩ(Снаб!I$1;ПОИСКПОЗ(СТРОКА(1:1);Снаб!$O:$O;0)-1;0);"")

Sub Вставить_формулы()
    Dim r As Range
    Set r = Cells(Rows.Count, 1).End(xlUp).Cells(2, 1)
    Range(Cells(2, r.Column + 3), r.Cells(1, 4)).FormulaR1C1 = "=RC[-2]*RC[-1]"
    Range(r.Cells(1, 2), r.Cells(1, 4)).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
    r.Value = "Итог"
End Sub

=КОЛИЧЕСТВО_МИНУСОВ(A1)

Function КОЛИЧЕСТВО_МИНУСОВ(Ячейка As Range) As Long
    Dim s As String
    s = Ячейка.Formula
    КОЛИЧЕСТВО_МИНУСОВ = Len(s) - Len(Replace(s, "-", ""))
End Function

Снаб!O6:O8          =O5+ЕСЛИ(A6;1;0)

Реестр!C6           =ЕСЛИОШИБКА(СМЕЩ(Снаб!D$1;ПОИСКПОЗ(СТРОКА(1:1);Снаб!$O:$O;0)-1;0);"")
Реестр!D6           =ЕСЛИОШИБКА(СМЕЩ(Снаб!E$1;ПОИСКПОЗ(СТРОКА(1:1);Снаб!$O:$O;0)-1;0);"")
...

Option Explicit

Public fso As Object

Sub Main()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    If Not IsEmpty(arr) Then
        PrintArr arr
    End If
End Sub

Sub PrintArr(arr As Variant)
    Dim y As Long
    Dim u As Long
    Dim i As Long
    Dim x As Integer
    Dim txt As String
    For y = 2 To UBound(arr, 1)
        u = y
        Do
           If u = UBound(arr, 1) Then Exit Do
           If arr(u + 1, 1) <> arr(u, 1) Then Exit Do
           u = u + 1
        Loop
        txt = arr(y, 1) & vbTab & arr(y, 2) & vbCrLf
        For i = y To u
            For x = 3 To UBound(arr, 2)
                txt = txt & arr(i, x) & vbTab
            Next
            txt = txt & vbCrLf
        Next
        WriteTxtFile txt
        y = u
    Next
End Sub

Sub WriteTxtFile(txt As String)
    Static i As Long
    i = i + 1
    Dim sFile As String
    sFile = ThisWorkbook.Path & "\" & Right("00000" & i, 6) & ".txt"
    On Error Resume Next
    Kill sFile
    On Error GoTo 0
    With fso.CreateTextFile(sFile)
        .Write txt
        .Close
    End With
End Sub

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 8))
    End With
End Function

Sub WhatFilesShouldBeOpened()
Dim varFilesToOpen As Variant
Dim varWb As Variant
Dim varFirstWbInArray As Variant
Dim x As Variant
Dim strWshName As String
 
'Вызываем диалог выбора файлов для импорта. varFilesToOpen - переменная массива, в котором содержатся все выбранные книги.
varFilesToOpen = Application.GetOpenFilename(FileFilter:="Excel files (*.xls*), *.xls*", MultiSelect:=True, Title:="Выберите файлы")
If TypeName(varFilesToOpen) = "Boolean" Then
    MsgBox "Не выбрано ни одного файла!"
    Exit Sub
End If
 
For Each varWb In varFilesToOpen
    Workbooks.Open varWb
Next varWb
 
'Мне нужно получить имя книги №1 в массиве varFilesToOpen
x = varFilesToOpen(1)
strWshName = Dir(varFilesToOpen(1))
MsgBox strWshName
End Sub

'2.2.Реестр затрат'!O2:O568            =СУММЕСЛИМН(G:G;M:M;M2)*(МЕСЯЦ(A2)=9)
C3                                     =ИНДЕКС('2.2.Реестр затрат'!M1:M568;ПОИСКПОЗ(МАКС('2.2.Реестр затрат'!O1:O568);'2.2.Реестр затрат'!O1:O568;0))

С2         =100000-МАКС((ЛЕВСИМВ('2.2.Реестр затрат'!C2:C568;15)="доставка кирпич")*(100000-'2.2.Реестр затрат'!F2:F568))

E1:E8       =ДАТА(ГОД(МИН('2.2.Реестр затрат'!A:A));МЕСЯЦ(МИН('2.2.Реестр затрат'!A:A))+СТРОКА()-1;1)
D1:D8       =СУММЕСЛИМН('2.2.Реестр затрат'!G:G;'2.2.Реестр затрат'!A:A;">="&E1;'2.2.Реестр затрат'!A:A;"<"&E2)
C1          =ТЕКСТ(ВПР(МАКС(D:D);D:E;2;0);"ММММ ГГГГ")

    Dim cl As Range
    'Ниже
    With Worksheets("List1")
        Set cl = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
    End With
'    'Выше
'    With Worksheets("List1")
'        Set cl = .Cells(1, 1).End(xlDown).Offset(-1, 0)
'    End With
    
    With cl
        .Range("A1").Value = TextBox1.Text
        .Range("B1").Value = TextBox2.Text
        .Range("C1").Value = TextBox2.Text
    End With

Sub AddNames()

    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.Names.Add Name:="Остаток", RefersToR1C1:="='" & sh.Name & "'!R35C7"
    Next
End Sub

=ДВССЫЛ(C4)

=ДВССЫЛ("'"&$O3&"'!Остаток")

V1:V191                  =ABS(Tabela1[@[Home Goal]]-СРЗНАЧ(D$2:D$191))>СТАНДОТКЛОН.Г(D$2:D$191)*$H$1

Option Explicit

Sub Макрос2()
     
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If Not r Is Nothing Then
        Dim arr As Variant
        If r.Cells.Count = 1 Then
            ReDim arr(1 To 1)
            arr(1) = r.Value
        Else
            arr = Intersect(Selection, ActiveSheet.UsedRange)
        End If
        Dim brr As Variant
        
        Dim v As Variant
        On Error Resume Next
        For Each v In arr
            Err.Clear
            With Sheets(v): End With
            If Err = 0 Then
                If IsEmpty(brr) Then
                    ReDim brr(0 To 0)
                Else
                    ReDim Preserve brr(0 To UBound(brr) + 1)
                End If
                brr(UBound(brr)) = v
            End If
        Next
        On Error GoTo 0
        Sheets(brr).Select
    End If
End Sub