Есть книга с 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
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
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