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
[/vba]
5+ тому кто написал The_Prist(Щербаков Дмитрий).
Добрый вечер знатоки VBA!!! Нашел макрос для сбора данных:
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
[/vba]
5+ тому кто написал The_Prist(Щербаков Дмитрий).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 - что после форматирования
Необходимо сделать чтобы все это делал сборщик - никаких лишних мышкодвижений
Прошу Вас помочь доработать это чудо макрос для моего случая. Я подробно опишу что нужно убрать и как я дорабатываю результат его работы:
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 - что после форматирования
Необходимо сделать чтобы все это делал сборщик - никаких лишних мышкодвиженийKorobkow
К сообщению приложен файл:_1.xlsm
(25.7 Kb)
·
_2.xlsm
(21.5 Kb)
А чего у Димы-то не спросите? Или Вы считаете что кому-то есть интерес чужие макросы разбирать и переписывать под чужие нужды? Да и не с конкретной задачей Вы обращаетесь, а с полноценным ТЗ - полностью переписать макрос
А чего у Димы-то не спросите? Или Вы считаете что кому-то есть интерес чужие макросы разбирать и переписывать под чужие нужды? Да и не с конкретной задачей Вы обращаетесь, а с полноценным ТЗ - полностью переписать макросSerge_007
Ну что Дима участник форума я знать не могу. Не знаю что такое ТЗ но это явно не оно. Т.к. то что я пытаюсь решить это и есть задача которую я сам себе придумал чтобы хоть немного облегчит ежедневный далеко не интересный труд, и не более. Спасибо за помощь, надеюсь корысть не сожрёт этот форум до конца. Всего доброго.
Ну что Дима участник форума я знать не могу. Не знаю что такое ТЗ но это явно не оно. Т.к. то что я пытаюсь решить это и есть задача которую я сам себе придумал чтобы хоть немного облегчит ежедневный далеко не интересный труд, и не более. Спасибо за помощь, надеюсь корысть не сожрёт этот форум до конца. Всего доброго.Korobkow