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

[SAS888]

Извините, что вмешиваюсь. Хочу сделать небольшое замечание (дополнение).
При изменении размерности массива с помощью ReDim Preserve, создается новый массив, в который перезаписываются все элементы текущего массива. Во-первых, т.к. мы заранее знаем количество обрабатываемых листов, то это делать совершенно ни к чему, во-вторых, не потребуется формировать массив "наоборот", а затем его транспонировать. Т.е. примерно так:

Sub Main()
    Dim sh As Worksheet, i As Long, a(): Application.ScreenUpdating = False
    If Sheets.Count = 1 Then Exit Sub
    ReDim a(1 To Sheets.Count - 1, 1 To 17): i = 1
    For Each sh In ThisWorkbook.Worksheets
        With sh
            If .Name <> ActiveSheet.Name Then
                a(i, 1) = .Name: a(i, 2) = .[D16]: a(i, 3) = .[D17]: a(i, 4) = .[D18]
                a(i, 5) = .[D19]: a(i, 6) = .[D20]: a(i, 7) = .[D21]: a(i, 8) = .[D22]
                a(i, 9) = .[C4]: a(i, 10) = .[C12]: a(i, 11) = .[C16]: a(i, 12) = .[C17]
                a(i, 13) = .[C18]: a(i, 14) = .[D19]: a(i, 15) = .[D20]
                a(i, 16) = .[D21]: a(i, 17) = .[D22]: i = i + 1
    End If: End With: Next: Range([A1], Cells(UBound(a, 1), 17)).Value = a
End Sub

P.S. Работу макроса можно еще ускорить, если формировать массив не явно присваивая каждому элементу значения ячейки, а в цикле по листам один раз обратиться к ячейкам, сформировав вспомогательный массив из диапазона "C4:D22", а затем переписывать данные из этого массива в результирующий, что существенно быстрее.

[nilem]

Хорошие замечания. Спасибо.
Получился еще один вариант:

Option Base 1 
Sub Main2()
Dim tm As Double
Dim sh As Worksheet, i As Long, j As Long, a(), aTemp(): Application.ScreenUpdating = False
    If Sheets.Count = 1 Then Exit Sub
    ReDim a(1 To Sheets.Count - 1, 1 To 17): i = 1: j = 1: tm = Timer
    For Each sh In ThisWorkbook.Worksheets
        With sh
            If .Name <> ActiveSheet.Name Then
            aTemp = Array(.Name, .[D16], .[D17], .[D18], .[D19], .[D20], .[D21], _
            .[D22], .[C4], .[C12], .[C16], .[C17], .[C18], .[D19], .[D20], .[D21], .[D22])
' еще вариант aTemp = .Range("C4:D22").Value, но потом муторно в а переносить
            For j = 1 To 17: a(i, j) = aTemp(j): Next j: i = i + 1
    End If: End With: Next: Range([A1], Cells(UBound(a, 1), 17)).Value = a
[R1] = "Main2: " & Timer - tm
End Sub

Провел лабораторную работу, по скорости выполнения на 50-ти листах места распределились таким образом:
1 - Main2 0,046875 сек
2 - Main 0,0546875 сек
3 - 2-й код (Дэлчев) 0,0625 сек
4 - 3-й код (Крупский) 0,12890625 сек.
Или можно еще как-то ускорить?
И попутно вопросик по поводу переключения обновления экрана. У нас обновление происходит, собственно, один раз: Range([A1], Cells(UBound(a, 1), 17)).Value "Бац" = a. Стоит ли ради одного Бац переключать ScreenUpdating?

[Hugo121]

У меня как-то раз ScreenUpdating = False только тормозил код в такой ситуации, потести.

[Bogusgl]

Блин! Мне теперь подругому надо!!!! )))))
Подскажите , а можно это все выполнить из другого файла.
Т.е. Делаем пустой файл, прикрепляем кнопку и макрос,
нажимаем на кнопку и макрос просит выбрать файл из которого все это будет собрано в тот пустой....
Вот так вот возможно?
И если да, может кто-то может рассказать как?

[nilem]

Вот другой блин. В пустом файле на лист - кнопку, на кнопку - макрос, макрос - в стандартный модуль.

Option Explicit
Option Base 1

Sub Main3()
Dim fd As FileDialog, ВыбранныйФайл As Variant
Dim sh As Worksheet, i As Long, j As Long, a(), aTemp()

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    .Title = "Выбираем файл": .InitialFileName = ThisWorkbook.Path
    .Filters.Add "Excel", "*.xls;*.xlsx;*.xlsm", 1: .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    Application.ScreenUpdating = False: ВыбранныйФайл = .SelectedItems(1)
    If ВыбранныйФайл = ThisWorkbook.FullName Then Exit Sub 'на всякий случай
    With Workbooks.Open(ВыбранныйФайл)
        ReDim a(1 To .Worksheets.Count, 1 To 17): i = 1: j = 1
        For Each sh In .Worksheets
            With sh: aTemp = Array(.Name, .[D16], .[D17], .[D18], .[D19], .[D20], .[D21], _
            .[D22], .[C4], .[C12], .[C16], .[C17], .[C18], .[D19], .[D20], .[D21], .[D22])
            For j = 1 To 17: a(i, j) = aTemp(j): Next j: i = i + 1
    End With: Next sh: End With
    Workbooks(Dir(ВыбранныйФайл, vbDirectory)).Close SaveChanges:=False
End With: Set fd = Nothing
  
'заполняем на активный лист
'ActiveSheet.UsedRange.ClearContents
Range([A1], Cells(UBound(a, 1), 17)).Value = a
Application.ScreenUpdating = True
End Sub

[SAS888]

еще вариант ... но потом муторно в а переносить

Может и муторно, зато быстро. Попробуйте протестировать на скорость следующий вариант:

Sub Main3()
    Dim sh As Worksheet, i As Long, a(), b(): Application.ScreenUpdating = False
    If Sheets.Count = 1 Then Exit Sub
    ReDim a(1 To Sheets.Count - 1, 1 To 17): i = 1
    For Each sh In ThisWorkbook.Worksheets
        With sh
            If .Name <> ActiveSheet.Name Then
                b = .Range("C4:D22").Value
                a(i, 1) = .Name: a(i, 2) = b(13, 2): a(i, 3) = b(14, 2): a(i, 4) = b(15, 2)
                a(i, 5) = b(16, 2): a(i, 6) = b(17, 2): a(i, 7) = b(18, 2): a(i, 8) = b(19, 2)
                a(i, 9) = b(1, 1): a(i, 10) = b(9, 1): a(i, 11) = b(13, 1): a(i, 12) = b(14, 1)
                a(i, 13) = b(15, 1): a(i, 14) = b(16, 1): a(i, 15) = b(17, 1)
                a(i, 16) = b(18, 1): a(i, 17) = b(19, 1): i = i + 1
    End If: End With: Next: Range([A1], Cells(UBound(a, 1), 17)).Value = a
End Sub

Что касается Application.ScreenUpdating = False, то, возможно, что это лишнее. Попробуйте с отключением обновления и без него.

[nilem]

SAS888, Ваш Sub Main3() лидирует с заметным отрывом 0,0078125 сек!
И без отключения обновления макросы все-таки замедляются (в разных случаях на разные величины).
Т.о. формируем массивы сразу из диапазонов и отключаем обновление экрана. Как-то так.