Данные из разных листов книги на один лист

[kangaroo]

Добрый день!
Существует книга, в которой несколько десятков листов. На всех листах одинаковая форма - значения в форме, соответственно, разные (собирается информация по филиальной сети). Названия листов соответствуют названиям филиалов.

Очень нужно, чтобы в этой же книге формировался новый лист, на котором в первом столбце выводились названия листов, а начиная со второго столбца определенный диапазон ячеек с каждого из листов. Предположим, С102:Н102.

Заранее очень благодарна.

P.S. Попыталась написать. Код ниже. Он работает, но мне кажется, можно не перечислять ячейки, а задать диапазон.

Sub SheetsList226()
Application.ScreenUpdating = False
Sheets.Add(Before:=Sheets(1)).Name = "List226"
Cnt = 0
For Elem = 2 To Sheets.Count
Sheets(1).Cells(1, 1).Offset(Cnt, 0) = Sheets(Elem).Name

Sheets(1).Cells("2,2").Offset(Cnt, 0) = Sheets(Elem).Range("C102")
Sheets(1).Cells("3,3").Offset(Cnt, 0) = Sheets(Elem).Range("D102")
Sheets(1).Cells("4,4").Offset(Cnt, 0) = Sheets(Elem).Range("E102")
Sheets(1).Cells("5,5").Offset(Cnt, 0) = Sheets(Elem).Range("F102")
Sheets(1).Cells("6,6").Offset(Cnt, 0) = Sheets(Elem).Range("G102")
Sheets(1).Cells("7,7").Offset(Cnt, 0) = Sheets(Elem).Range("H102")


Cnt = Cnt + 1


Next Elem
Application.ScreenUpdating = False
End Sub

[pashulka]

Private Sub SheetsList226()
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet, iCount&, iRow&
    Set ws = Worksheets.Add(Worksheets(1)) 'ws.Name = "List226"
    
    For iCount = 2 To Worksheets.Count
        ws.[A1].Offset(iRow) = Worksheets(iCount).Name
        ws.[B1:G1].Offset(iRow) = Worksheets(iCount).[C102:H102].Value
        iRow = iRow + 1
    Next
    
    Application.ScreenUpdating = False
End Sub

или так :

Private Sub SheetsList227()
    Dim iRow&, iColumn&, ws As Worksheet
    ReDim iArr(1 To Worksheets.Count, 1 To 7)
    
    For Each ws In Worksheets
        iRow = iRow + 1
        For iColumn = 2 To 7
            iArr(iRow, iColumn) = ws.Cells(102, iColumn + 1)
        Next
        iArr(iRow, 1) = ws.Name
    Next
    
    Set ws = Worksheets.Add(Worksheets(1))
    ws.Range("A1:G1").Resize(iRow) = iArr ': ws.Name = "List227"
End Sub

[kangaroo]

Спасибо большое! Всё работает.

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

Спасибо.

Подозреваю, что что-то типа этого:

Sub Worksheet_Activate()
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
Debug.Print sh.Name
If sh.Index <> ThisWorkbook.ActiveSheet.Index Then
Cells(sh.Index, 1).Value = sh.Name
Cells(sh.Index, 2).FormulaR1C1 = "=INDIRECT(CONCATENATE(RC[-1],""!$C$102""))"
Cells(sh.Index, 3).FormulaR1C1 = "=INDIRECT(CONCATENATE(RC[-2],""!$D$102""))"
Cells(sh.Index, 4).FormulaR1C1 = "=INDIRECT(CONCATENATE(RC[-3],""!$E$102""))"
Сells(sh.Index, 5).FormulaR1C1 = "=INDIRECT(CONCATENATE(RC[-4],""!$F$102""))"
Cells(sh.Index, 6).FormulaR1C1 = "=INDIRECT(CONCATENATE(RC[-5],""!$G$102""))"
Cells(sh.Index, 7).FormulaR1C1 = "=INDIRECT(CONCATENATE(RC[-6],""!$H$102""))"

End If
Next sh
End Sub
но не знаю, как из этого сделать цикл.

[27102014]

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

Спасибо большое! Всё работает.

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

подозраваю что сами не очень понимаете что Вам нужно....

[pashulka]

kangaroo, Если нужны ссылки, то в первом варианте - замените

ws.[B1:G1].Offset(iRow) = Worksheets(iCount).[C102:H102].Value

на

ws.[B1:G1].Offset(iRow).FormulaArray = "=" & Worksheets(iCount).Name & "!C102:H102"

или

ws.[B1:G1].Offset(iRow).FormulaArray = "=" & Worksheets(iCount).[C102:H102].Address(External:=True)

[kangaroo]

СПАСИБО!!!