Распределение данных из файлов по страницам в новой книге

[ff0000]

Нужно чтоб код работал следующим образом:
1. выбираешь файлы
2. с листа №1 копируется информация
3. создается новый документ
4. скопированная информация вставляется на отдельный лист с именем файла.
5. сохраняется как итог+дата


Сейчас этот код работает следующим образом:
1. выбираешь файлы
2. с листа №1 копируется информация
3. создается новый документ
4. скопированная информация вставляется на " лист 4" друг под дружкой
5. сохраняется как итог+дата

пункт 4

Attribute VB_Name = "mConsolidated"
Option Explicit

Sub Consolidated_Range_of_Books_and_Sheets()
    Dim iBeginRange As Object, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
    Dim wbAct As Workbook
    Dim bPasteValues As Boolean
    
    On Error Resume Next
    'Выбираем диапазон выборки с книг
    Set iBeginRange = Range("A10:Z20") 'диапазон указывается нужный
    If iBeginRange Is Nothing Then Exit Sub
    'Указываем имя листа
    sSheetName = "Лист1"
    On Error GoTo 0
    'Вставлять значения ячеек (без формул и форматов)
    bPasteValues = vbYes
    'Cбор данных с книг
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 1
    'отключаем обновление экрана, автопересчет формул и отслеживание событий
    'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    End With
'    'создаем новый лист в книге для сбора
    Set wsDataSheet = Workbooks.Add.Sheets.Add(After:=Sheets(Sheets.Count))
'    цикл по книгам
'    'вызываем диалог выбора файлов для импорта
  
    For li = LBound(avFiles) To UBound(avFiles)
        If bPolyBooks Then
            Set wbAct = Workbooks.Open(Filename:=avFiles(li))
        Else
            Set wbAct = ThisWorkbook
        End If
        oAwb = wbAct.Name
         'создаем новый лист в книге для сбора
         wsDataSheet.Name = oAwb
        'цикл по листам
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                'Если имя листа совпадает с именем листа, в который собираем данные
                'и сбор идет только с активной книги - то переходим к следующему листу
                If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                With wsSh
                    Select Case iBeginRange.Count
                    Case 1 'собираем данные начиная с указанной ячейки и до конца данных
                        lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
                        iLastColumn = .Cells.SpecialCells(xlLastCell).Column
                        sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
                    Case Else 'собираем данные с фиксированного диапазона
                        sCopyAddress = iBeginRange.Address
                    End Select
                    lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
                    'вставляем имя книги, с которой собраны данные
                    If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb
                    If bPasteValues Then 'если вставляем только значения
                        .Range(sCopyAddress).Copy
                        wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
                    Else
                        .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                    End If
            End With
                 Application.CutCopyMode = False
            End If

NEXT_:
        Next wsSh
        If bPolyBooks Then wbAct.Close False
    Next li
    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
    End With
ActiveWorkbook.SaveAs Filename:="Itog_" & Date & "_.xls"
    
End Sub