Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Cобрать данные из нескольких книг?
 
Добрый день!
В библиотеке хитростей  на смежном сайте нашел следующий макрос
Подскажите пожалуйста как его изменить так, чтобы строка с заголовками копировалась только из первой таблицы, а начало диапазона можно было задать в коде (для возможности автоматизации и работы без запросов, кроме запроса выбора фалов для объединения)?
Самый стандартный вариант - первая строка заголовки, а все данные начинаются с А2.
Код
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
Скрытый текст
Изменено: К М - 21 Апр 2015 09:59:11
Karim
 
Забавно. Вы разместили там вопрос в полвторого ночи. Как думаете, много людей сидят в такое время на форумах в поисках подобных задач? :-) Вы хоть учитывайте, что ночью люди обычно спят и большая часть людей на форуме все же в часовом поясе МСК или приближены к нему. И в час ночи почти все спят.

Ответил там.

P.S. Ссылка на ту тему: http://www.excel-vba.ru/forum/index.php?topic=3815
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Уберите все строки с InputBox(),
переменные iBeginRange, sSheetName - задайте как вам нужно (iBeginRange=Range("A2:F10") и sSheetName="Лист1")
Неизлечимых болезней нет, есть неизлечимые люди.
 
Решение получено человеком на форуме по ссылке.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Не подскажите, а как сделать вывод названий листов откуда взяты данные. В коде есть возможность вывода названия книги, как сделать, чтобы рядом со значениями выводились названия листов
 
Sheet.Name
Страницы: 1
Читают тему (гостей: 1)