Сбор данных с листов - доработка макроса

[Korobkow]

Прошу Вас помочь доработать этот чудо макрос для моего случая.

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

     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
         lCol = 1
     Else
         avFiles = Array(ThisWorkbook.FullName)
     End If
     'отключаем обновление экрана, автопересчет формул и отслеживание событий
     'для скорости выполнения кода и для ибежания ошибок, если в книгах есть иные коды
     With Application
         lCalc = .Calculation
         .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
     End With
     'создаем новый лист в книге для сбора
     ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
     Set wsDataSheet = ThisWorkbook.ActiveSheet
     'цикл по книгам
     For li = LBound(avFiles) To UBound(avFiles)
         If bPolyBooks Then Workbooks.Open Filename:=avFiles(li)
         oAwb = Dir(avFiles(li), vbDirectory)
         'цикл по листам
         For Each wsSh In Workbooks(oAwb).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
                     .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                 End With
             End If
 NEXT_:
         Next wsSh
         If bPolyBooks Then Workbooks(oAwb).Close False
     Next li
     With Application
         .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
     End With
End Sub

[Korobkow]

Я подробно опишу что нужно убрать и как я дорабатываю результат его работы:

1. Убрать запрос на выделение диапазона , а назначить его жёстко =$C$9:$C$21;$E$9:$E$21;$H$9:$I$21;$ L$9:$L$21
2. Убрать запрос имени листа - он в моём случае единственный
3. Убрать запрос о сборе данных с нескольких книг, а сразу открыть директорию с кучей книг расположенную D:\Сбор\2014

И результат:

1. Очистиь форматирование - привести к стандарту (Arial Cyr 10)
2. Между стобцами А и В вставляю два столбца, затем разделяю первый столбец на три "текст по столбцам" разделитель "_". Первый столбец имеет вормат "dd.mm.yyyy_Time_[D5]" (01.01.2014_081451_Иванов.xls)
3. Затем удаляю столбец "B", где время,
4. Удаляю .xls во всех ячейках
5. Ищу пустые ячейки в Столбце В и удаляю стоки, затем в столбце С и тоже удаляю строки

Файл 1 - что получается после сбора
Файл 2 - что после форматирования
Файл 3 - Сам Сборщик
Необходимо сделать чтобы все это делал сборщик

[IgorGO]

пунктом 0 надо написать:

0. видите макрос в предыдущем сообщении? забудьте о нем!

[Korobkow]

Сообщение от IgorGO

забудьте о нем!

От чего же так критично, проще вытряхнуть пепельницу, чем покупать новый автомобиль. Я уверен что для человека который понимает язые VBA это бооще труда не составит, только проблема, где найти такого человека?

[IgorGO]

ну, извините...

у макроса, который будет написан для решения задачи, описанной во 2-м сообщение, с макросом из 1-го сообщения общего будет только то, что оба они будут на VBA

и по поводу вытряхивания пепельниц:
понимаете, если я где-то однажды использовал For ... Next - это не значит, что для каждого следующего случая использования цикла я должен скопировать For ... Next из той самой первой процедуры и подправить его до нужных кондиций

[Korobkow]

Сообщение от IgorGO

если я где-то однажды использовал For ... Next

т.е. это Ваш макрос?
Или Вы именно тот человек который может мне помочь?

[Korobkow]

УПС а в ответ тишина я так и думал

[Ves67]

korobkow у вас задание очень большое,поэтому не удивяйтесь ,что вам никто не помогает.

[IgorGO]

Вы меня с кем-то перепутали. я сомневаюсь человек-ли я вообще, не говоря уже о том, что я именно ТОТ человек