Создать таблицу - отчет.

[Омега]

Сколько веток читал на форуме, стеба не встречал. Думал здесь все строго до флуда. Хотя улыбнуться иногда надо.

Переписка перепиской. Просто когда тупой пришел к умному, то и вопросы у него тупые. Поэтому алгоритм действий (возьми это, положи туда, получишь это) для меня, как для не образованного необходим и спасибо Игорю, что он пошел на все эти мытарства.

[Hugo121]

Попробуйте такой вариант:

Option Explicit
Dim wb As Workbook

Sub vizov()
    Application.ScreenUpdating = False
    Set wb = Workbooks.Add(1)
    With ThisWorkbook.Sheets("переход.")

        svod "E36:IJ39", 3, .Range("D36:D39")
        svod "E40:IJ43", 3, .Range("D40:D43")
        svod "E44:IJ47", 3, .Range("D44:D47")

    End With

    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub


Private Sub svod(r1 As String, r2 As Long, r3 As Range)
    Dim i&, ii&, t, arr$, sh As Object

    With wb.Sheets.Add(Before:=Worksheets(1))
        .Cells(1).Value = "дата анализа"
        .Cells(2, 1).Value = Now()

        arr = "|переход|фасады|стекло-переделки-конструкции|купе|1 склад|2 склад|Химиков|Магнитогорская|"

        ReDim a(1 To 4, 1 To 1)
        For i = 1 To ThisWorkbook.Sheets.Count
            If InStr(arr, "|" & ThisWorkbook.Sheets(i).Name & "|") Then
                Application.StatusBar = "Обработка листа " & ThisWorkbook.Sheets(i).Name
                t = ThisWorkbook.Sheets(i).Range(r1).Value
                For ii = 1 To Range(r1).Columns.Count
                    If t(1, ii) <> 0 Then
                        a(1, 1) = t(1, ii)
                        a(2, 1) = t(2, ii)
                        a(3, 1) = t(3, ii)
                        a(4, 1) = t(4, ii)

                        r3.Copy .Cells(r2, 1)
                        .Cells(r2, 2).Resize(4, 1) = a

                        r2 = r2 + 4
                    End If
                Next
            End If
        Next

        .Columns(1).EntireColumn.AutoFit

        With .PageSetup
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
    End With

End Sub

[Омега]

Игорь прости, но видимо я не правильно объясняю.
вид нужен такой.
фото.rar
Одна книга, на одном листе "общие данные" только вниз уходит

[Hugo121]

Я понял этот третий вариант "хотелки" - выше уже писал "опять переписывать на 90% код, совмещая два в одном".
Сейчас некогда. Может завтра, если будут "окна" на работе.