Sub Clear()
    Dim BazaWb As Workbook 'отчет
    Dim BazaList As Range 'список проверяемых листов
    Dim iNameSht As String ' имя проверяемого листа
        Set BazaWb = ThisWorkbook
        Set BazaList = BazaWb.Worksheets("Адрес").Range("F2:F6") 'устанавливаем список листов
            For Each n In BazaList 'для каждого листа из списка удаляем элементы управления
                iNameSht = n
                If iNameSht <> "" And iNameSht <> "КТТ" Then 'исключаем из проверки один из листов в списке и пустые позиции
                With Sheets(iNameSht)
                    Rows.Hidden = False   'отменяем все скрытия строк
                    Columns.Hidden = False   'отменяем все скрытия строк
                    .Shapes.Delete
                End With
                End If
            Next
End Sub

Function UseThisName(iName As String)
    UseThisName = Name(iName).Value
End Function

Вариант 1:
Function wbFind(IDRange As Range, iNumberColumn As Long, StCell As String, Number1 As Integer, Number2 As Integer)

    wbFind = Thisworkbooks.Sheets("ТК_" & Left(IDRange.Value, 3)).Columns(iNumberColumn) _
            .Find(IDRange.Value, Range(StCell), xlValues, xlWhole, xlByRows, xlNext).cell.Offset(Number1, Number2).Value

End Function

Вариант 2:
Function WbIndex(IDRange As Range, iRangeValue As String, iRangeCri As String)
    
    WbIndex = Application.WorksheetFunction.Index(Thisworkbooks.Sheets("ТК_" & Left(IDRange.Value, 3)).Range(iRangeValue), _
            WorksheetFunction.Match(IDRange, Thisworkbooks.Sheets("ТК_" & Left(IDRange.Value, 3)).Range(iRangeCri), 0))

End Function

Sub consolidation()
    Dim BazaWb As Workbook 'консолидирующая книга
    Dim BazaAdress As Range 'список адресов месторасположения файлов
    Dim BazaList As Range 'список консолидируемых листов
    Dim BazaSht As Worksheet 'консолидирующий лист
    Dim iTempFileName As String 'путь к файлам-источникам
    Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле по столбцу
    Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очередно открываемом файле по столбцу
    Dim iNumFiles As Long 'количество открываемых источников
    With Application
       .ScreenUpdating = False
       .DisplayAlerts = False
       .Calculation = xlManual
       Set BazaWb = ThisWorkbook
       Set BazaAdress = BazaWb.Worksheets("Адрес").Range("D2:D23")
       Set BazaList = BazaWb.Worksheets("Адрес").Range("F2:F6")
       For Each i In BazaList
            iLastRowBaza = BazaWb.i.Cells(Rows.Count, 2).End(xlUp).Row + 1
                    .Range(.Cells(5, 2), .Cells(iLastRowBaza, "*")).Clear
       i = i + 1
       Next
       For Each i In BazaAdress
       iTempFileName = i
            Do While iTempFileName <> ""
               With .Workbooks.Open _
                    (Filename:=iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                    iNumFiles = iNumFiles + 1
                    'Рабочая книга не должна быть защищена паролем
                    For Each i In BazaList
                    With .i
                         iLastRowTempWb = .Cells(Rows.Count, 3).End(xlUp).Row
                         iLastRowBaza = BazaWb.i.Cells(Rows.Count, 2).End(xlUp).Row + 1
                         .Range(.Cells(4, 1), .Cells(iLastRowTempWb, "*")).Copy
                         BazaWb.i.Cells(iLastRowBaza, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                         :=False, Transpose:=False
                    End With
                    i = i + 1
                    Next
                   .Close saveChanges:=False
                End With
              End If
        i = i + 1
        Next
       Loop
       .Calculation = xlAutomatic
       .DisplayAlerts = True
       .ScreenUpdating = True
   End With
   MsgBox "Информация собрана из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub

     Function MyIndex(Range1 As Range, Range2 As Range, X As Integer)
          MyIndex = Application.WorksheetFunction.Index(Range1, Application.WorksheetFunction.Match(X, Range2, 0))
     End Function