Страницы: 1
RSS
Сборка информации с листов книги в единую таблицу
 
Доброго времени, планетяне!

Есть книга с n-ным количеством листов. Необходимо собрать данные с листов в единую таблицу. Нашел замечательный макрос в разделе Приемы. Но он не совсем подошел. Я его, как понял, немного подкорректировал под свои задачи, но не знаю, насколько правильно.
Таблица должна содержать название листа и данные из ячейки А1. Как в макросе указать необходимость собирать названия листов книги?

В примере, конечный результат, содержится на листе "Собранные данные"

Заранее благодарю за помощь.
 
Доброго. Когда в макросе запускаете цикл, в котором определяется диапазон для копирования в итоговый лист, сразу пишите в итоговые данные имя листа, с которого чего скопировали. Если пользоваться кодом из примера, то:
Код
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 2)
        wbReport.Worksheets(1).Cells(n + 1, 1)=ws.Name
Кому решение нужно - тот пример и рисует.
 
Пытливый, спасибо за отклик.

Вставил Ваш код в макрос. Но, видимо, я изначальный код сильно "покорежил", макрос срабатывает до конца, но не собирает данные с листов.
Может взгляните, что там не так я сделал?
 
В вашем примере нет текста макроса. Чего вы "корежили" - не видать. :)
Кому решение нужно - тот пример и рисует.
 
Макрос в гиперссылке на раздел Приемы этого сайта. Выкладываю в тело сообщения.
Он для сборки диапазонов, я все диапазоны поубирал, оставил только А1. Как-то так.
Черт, в режиме Просмотр нормально код лег, а в сообщении в одну строку стал. Что я не так сделал?

Код
Sub CollectDataFromAllSheets()    Dim ws As Worksheet
     
    Set wbCurrent = ActiveWorkbook
    Workbooks.Add
    Set wbReport = ActiveWorkbook
     
    'копируем на итоговый лист шапку таблицы из первого листа
    wbCurrent.Worksheets(1).Range("A1:D1").Copy Destination:=wbReport.Worksheets(1).Range("A1")
     
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
     
        'определяем номер последней строки на текущем листе и на листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
         
        'задаем исходный диапазон, который надо скопировать с каждого листа - любой вариант на выбор:
        Set rngData = ws.Range("A1:D5")            'фиксированный диапазон или
        Set rngData = ws.UsedRange                 'всё, что есть на листе или
        Set rngData = ws.Range("F5").CurrentRegion    'область, начиная от ячейки F5 или
        Set rngData = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))    'от А2 и до конца листа
         
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)
         
    Next ws
End Sub
Изменено: Newbie - 06.06.2019 15:30:49
 
Код
Sub PivotSheet()
Dim Sh As Worksheet, arr(), I&
ReDim arr(1 To Worksheets.Count - 1, 1 To 2)
For Each Sh In Worksheets
    If Sh.Name <> "Собранные данные" Then
        I = I + 1
        arr(I, 1) = Sh.Name
        arr(I, 2) = Sh.Range("A1").Value
    End If
Next
Worksheets("Собранные данные").Range("A2").Resize(UBound(arr), 2) = arr
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Пока писал сообщение для Пытливый, пришло решение. Sanja, Пытливый, спасибо.
Тема завершена.
 
Еще вариант.
Код
Sub Button1_Click()
    Application.ScreenUpdating = False
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    If lr > 1 Then Range("A2:B" & lr).ClearContents
    cr = 2
    For i = 2 To Sheets.Count
        Cells(cr, "A") = Sheets(i).Name
        Cells(cr, "B") = Sheets(i).Cells(1, 1)
        cr = cr + 1
    Next
    Application.ScreenUpdating = True
    MsgBox "Готово!"
End Sub
Страницы: 1
Наверх