Sub Consolidated_Range_of_Books_and_Sheets111()
    Dim iBeginRange As Object, lCalc As Long
    Dim sRngAddress As String, oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn, kolvo_list, i, flag1 As Integer
    Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
    On Error Resume Next
    Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
                                           "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
                                           vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
    If iBeginRange Is Nothing Then Exit Sub
    sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
    If sSheetName = "" Then sSheetName = "*"
    On Error GoTo 0
    If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If
    
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    End With
    
    flag1 = 0
   kolvo_list = ThisWorkbook.Sheets.Count
   For i = 1 To kolvo_list
     lLastColMyBook = 4
     Set wsDataSheet = ThisWorkbook.Sheets(i)
     sSheetName = wsDataSheet.Name
  
    flag1 = 0
   For li = LBound(avFiles) To UBound(avFiles)
      flag1 = 0
       If bPolyBooks Then Workbooks.Open Filename:=avFiles(li)
        oAwb = Dir(avFiles(li), vbDirectory)
        Do While flag1 = 0
         For Each wsSh In Workbooks(oAwb).Sheets
          
           If wsSh.Name Like sSheetName Then
                flag1 = 1
                
                With wsSh
                    Select Case iBeginRange.Count
                    Case 1
                        lLastrow = 21
                        iLastColumn = 4
                        sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
                    Case Else
                        sCopyAddress = iBeginRange.Address
                        lLastrow = iBeginRange.Rows.Count
                        iLastColumn = iBeginRange.Columns.Count
                    End Select
                    lLastColMyBook = lLastColMyBook + 2
                    sRngAddress = .Range(.Cells(3, lLastColMyBook), .Cells(lLastrow, iLastColumn + lLastColMyBook)).Address
                    .Range(sCopyAddress).Copy wsDataSheet.Range(sRngAddress)
                    wsDataSheet.Cells(2, lLastColMyBook) = "ТОО № " + Mid(Workbooks(oAwb).Name, 10, 4)
                    wsDataSheet.Columns.AutoFit
                    wsDataSheet.Rows.AutoFit
                End With
            End If
           Next wsSh
           Loop
        
    Next li
 Next i
 

    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
    End With
End Sub