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

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

пункт 4

Код :
  1. Option Explicit
  2.  
  3. Sub Consolidated_Range_of_Books_and_Sheets()
  4.     Dim iBeginRange As Object, lCalc As Long, lCol As Long
  5.     Dim oAwb As String, sCopyAddress As String, sSheetName As String
  6.     Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
  7.     Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
  8.     Dim wbAct As Workbook
  9.     Dim bPasteValues As Boolean
  10.    
  11.     On Error Resume Next
  12.     'Выбираем диапазон выборки с книг
  13.     Set iBeginRange = Range("A10:Z20") 'диапазон указывается нужный
  14.     If iBeginRange Is Nothing Then Exit Sub
  15.     'Указываем имя листа
  16.     sSheetName = "Лист1"
  17.     On Error GoTo 0
  18.     'Вставлять значения ячеек (без формул и форматов)
  19.     bPasteValues = vbYes
  20.     'Cбор данных с книг
  21.         avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
  22.         If VarType(avFiles) = vbBoolean Then Exit Sub
  23.         bPolyBooks = True
  24.         lCol = 1
  25.     'отключаем обновление экрана, автопересчет формул и отслеживание событий
  26.     'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
  27.     With Application
  28.         lCalc = .Calculation
  29.         .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
  30.     End With
  31. '    'создаем новый лист в книге для сбора
  32.     Set wsDataSheet = Workbooks.Add.Sheets.Add(After:=Sheets(Sheets.Count))
  33. '    цикл по книгам
  34. '    'вызываем диалог выбора файлов для импорта
  35.  
  36.     For li = LBound(avFiles) To UBound(avFiles)
  37.         If bPolyBooks Then
  38.             Set wbAct = Workbooks.Open(Filename:=avFiles(li))
  39.         Else
  40.             Set wbAct = ThisWorkbook
  41.         End If
  42.         oAwb = wbAct.Name
  43.          'создаем новый лист в книге для сбора
  44.          wsDataSheet.Name = oAwb
  45.         'цикл по листам
  46.         For Each wsSh In wbAct.Sheets
  47.             If wsSh.Name Like sSheetName Then
  48.                 'Если имя листа совпадает с именем листа, в который собираем данные
  49.                 'и сбор идет только с активной книги - то переходим к следующему листу
  50.                 If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
  51.                 With wsSh
  52.                     Select Case iBeginRange.Count
  53.                     Case 1 'собираем данные начиная с указанной ячейки и до конца данных
  54.                         lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
  55.                         iLastColumn = .Cells.SpecialCells(xlLastCell).Column
  56.                         sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
  57.                     Case Else 'собираем данные с фиксированного диапазона
  58.                         sCopyAddress = iBeginRange.Address
  59.                     End Select
  60.                     lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
  61.                     'вставляем имя книги, с которой собраны данные
  62.                     If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb
  63.                     If bPasteValues Then 'если вставляем только значения
  64.                         .Range(sCopyAddress).Copy
  65.                         wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
  66.                     Else
  67.                         .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
  68.                     End If
  69.             End With
  70.                  Application.CutCopyMode = False
  71.             End If
  72.  
  73. NEXT_:
  74.         Next wsSh
  75.         If bPolyBooks Then wbAct.Close False
  76.     Next li
  77.     With Application
  78.         .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
  79.     End With
  80. ActiveWorkbook.SaveAs Filename:="Itog_" & Date & "_.xls"
  81.    
  82. End Sub