VBA Код жутко тормазит, помогите разобраться...

[Bogusgl]

Мне нужно собрать данные с более чем 100 листов в один лист.
Нашел и подредактировал такой код, но он жудко тормазит (комп виснет на 20-30 минут).
Кто знает, подскажите почему и что делать?
ПОМАГИТЕ ПЛИЗ!!!
(Сам я чайник !!!)

Код Visual Basic

  Private 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, 1).Value = sh.Name
Cells(sh.Index+1, 2).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-1],""'"",""!$D$16""))"
Cells(sh.Index+1, 3).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-2],""'"",""!$D$17""))"
Cells(sh.Index+1, 4).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-3],""'"",""!$D$18""))"
Cells(sh.Index+1, 5).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-4],""'"",""!$D$19""))"
Cells(sh.Index+1, 6).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-5],""'"",""!$D$20""))"
Cells(sh.Index+1, 7).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-6],""'"",""!$D$21""))"
Cells(sh.Index+1, 8).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-7],""'"",""!$D$22""))"
Cells(sh.Index+1, 9).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-8],""'"",""!$C$4""))"
Cells(sh.Index+1, 10).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-9],""'"",""!$C$12""))"
Cells(sh.Index+1, 11).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-10],""'"",""!$C$16""))"
Cells(sh.Index+1, 12).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-11],""'"",""!$C$17""))"
Cells(sh.Index+1, 13).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-12],""'"",""!$C$18""))"
Cells(sh.Index+1, 14).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-13],""'"",""!$D$19""))"
Cells(sh.Index+1, 15).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-14],""'"",""!$D$20""))"
Cells(sh.Index+1, 16).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-15],""'"",""!$D$21""))"
Cells(sh.Index+1, 17).FormulaR1C1 = "=INDIRECT(CONCATENATE(""'"",RC[-16],""'"",""!$D$22""))"
End If
Next sh
End Sub 

[nilem]

На листе нужно заполнить именно формулы или достаточно перенести значения из ячеек с других листов?

[Bogusgl]

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

На листе нужно заполнить именно формулы или достаточно перенести значения из ячеек с других листов?

Нужно просто забрать и вставить на Лист1 значения из ячеек других листов (правда в тех листах в ячейках попадаются формулы.)

[nilem]

Ну, у меня 2 варианта - Крупский и Дэлчев.

Private Sub Worksheet_Activate()
Dim sh As Worksheet, i As Integer
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
With sh
    If .Index <> ThisWorkbook.ActiveSheet.Index Then
        i = .Index + 1
        Cells(i, 1).Value = .Name
        Cells(i, 2).Value = .[D16]: Cells(i, 3).Value = .[D17]
        Cells(i, 4).Value = .[D18]: Cells(i, 5).Value = .[D19]
        Cells(i, 6).Value = .[D20]: Cells(i, 7).Value = .[D21]
        Cells(i, 8).Value = .[D22]: Cells(i, 9).Value = .[C4]
        Cells(i, 10).Value = .[C12]: Cells(i, 11).Value = .[C16]
        Cells(i, 12).Value = .[C17]: Cells(i, 13).Value = .[C18]
        Cells(i, 14).Value = .[D19]: Cells(i, 15).Value = .[D20]
        Cells(i, 16).Value = .[D21]: Cells(i, 17).Value = .[D22]
    End If
End With
Next sh
Application.ScreenUpdating = True
End Sub

и этот, наверное, лучше

Private Sub Worksheet_Activate()
Dim sh As Worksheet, i As Long, X(), rng As Range
i = 1
For Each sh In ThisWorkbook.Worksheets
With sh
    If .Index <> ThisWorkbook.ActiveSheet.Index Then
        ReDim Preserve X(1 To 17, 1 To i)
        X(1, i) = .Name: X(2, i) = .[D16]: X(3, i) = .[D17]: X(4, i) = .[D18]
        X(5, i) = .[D19]: X(6, i) = .[D20]: X(7, i) = .[D21]: X(8, i) = .[D22]
        X(9, i) = .[C4]: X(10, i) = .[C12]: X(11, i) = .[C16]: X(12, i) = .[C17]
        X(13, i) = .[C18]: X(14, i) = .[D19]: X(15, i) = .[D20]
        X(16, i) = .[D21]: X(17, i) = .[D22]: i = i + 1
    End If
End With
Next sh
Set rng = [A3].Resize(UBound(X, 2), 17)
rng.Value = WorksheetFunction.Transpose(X)
End Sub

Может, будет лучше назначить на кнопку?

[Bogusgl]

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

Может, будет лучше назначить на кнопку?

На кнопку... А пожалуй что и лучше...Ща попробую коды... )))
Спасибо!

[Bogusgl]

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

Private Sub Worksheet_Activate()
Dim sh As Worksheet, i As Long, X(), rng As Range
i = 1
For Each sh In ThisWorkbook.Worksheets
With sh
    If .Index <> ThisWorkbook.ActiveSheet.Index Then
        ReDim Preserve X(1 To 17, 1 To i)
        X(1, i) = .Name: X(2, i) = .[D16]: X(3, i) = .[D17]: X(4, i) = .[D18]
        X(5, i) = .[D19]: X(6, i) = .[D20]: X(7, i) = .[D21]: X(8, i) = .[D22]
        X(9, i) = .[C4]: X(10, i) = .[C12]: X(11, i) = .[C16]: X(12, i) = .[C17]
        X(13, i) = .[C18]: X(14, i) = .[D19]: X(15, i) = .[D20]
        X(16, i) = .[D21]: X(17, i) = .[D22]: i = i + 1
    End If
End With
Next sh
Set rng = [A3].Resize(UBound(X, 2), 17)
rng.Value = WorksheetFunction.Transpose(X)
End Sub

не работает, говорит : Type mismatch (Error 13)

[Bogusgl]

А первый код работает просто отлично!
Спасибо!
Посадил на кнопку, проверил - изЮмительно!

[Hugo121]

Но второй должен работать намного быстрее.

[аналитика]

у меня работает!

[nilem]

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

не работает, говорит : Type mismatch (Error 13)

Будет очень жаль, если не заработает. Вот смотрите в моем файле - на первом листе зеленая кнопка.