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

[Hugo121]

Я на мобильный счет денег не принимаю!
Только как в подписи (хотя если введут все санкции, будет скучно...)

[Hugo121]

Добавил выбор листов, алгоритм прежний:

Option Explicit

Sub vizov()
    svod "E36:IJ39", "b30"
    svod "E40:IJ43", "b34"
    svod "E44:IJ47", "b38"
End Sub


Private Sub svod(r1 As String, r2 As String)
    Dim i&, ii&, t, arr$

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

    ReDim a(1 To 4, 1 To 1)
    For i = 1 To Sheets.Count
        If InStr(arr, "|" & Sheets(i).Name & "|") Then
            t = Sheets(i).Range(r1).Value
            For ii = 1 To Range(r1).Columns.Count
                If t(1, ii) <> 0 Then
                    a(1, UBound(a, 2)) = t(1, ii)
                    a(2, UBound(a, 2)) = t(2, ii)
                    a(3, UBound(a, 2)) = t(3, ii)
                    a(4, UBound(a, 2)) = t(4, ii)
                    ReDim Preserve a(1 To 4, 1 To UBound(a, 2) + 1)
                End If
            Next
        End If
    Next

    If UBound(a, 2) > 1 Then Sheets("общие данные").Range(r2).Resize(4, UBound(a, 2) - 1) = a

[Hugo121]

Есть мысль как несложно изменить код... Правда не будет так быстро работать, но будет...

[Hugo121]

Попробуйте такой код.
Но сперва создайте лист Sheets("общие данные")

Option Explicit

Sub vizov()
    Dim ind&
    ind = 3
    Application.ScreenUpdating = False
    With Sheets("общие данные")
        .UsedRange.Clear
        .Cells(1).Value = "дата анализа"
        .Cells(2, 1).Value = Now()
    End With
    svod "E36:IJ39", ind, Sheets("переход.").Range("D36:D39")
    svod "E40:IJ43", ind, Sheets("переход.").Range("D40:D43")
    svod "E44:IJ47", ind, Sheets("переход.").Range("D44:D47")
    Application.ScreenUpdating = True
End Sub



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

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

    ReDim a(1 To 4, 1 To 1)
    For i = 1 To Sheets.Count
        If InStr(arr, "|" & Sheets(i).Name & "|") Then
            t = 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)
                    With Sheets("общие данные")
                        r3.Copy .Cells(r2, 1)
                        .Cells(r2, 2).Resize(4, 1) = a
                    End With
                    r2 = r2 + 4
                End If
            Next
        End If
    Next

End Sub

[Hugo121]

Вызов может быть такой:

Sub vizov()
    Dim ind&
    ind = 3
    Application.ScreenUpdating = False
    With Sheets("общие данные")
        .UsedRange.ClearContents
        .Cells(1).Value = "дата анализа"
        .Cells(2, 1).Value = Now()

        svod "E36:IJ39", ind, Sheets("переход.").Range("D36:D39")
        svod "E40:IJ43", ind, Sheets("переход.").Range("D40:D43")
        svod "E44:IJ47", ind, Sheets("переход.").Range("D44:D47")

        .Columns(1).EntireColumn.AutoFit

        With .PageSetup
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
            .LeftMargin = Application.InchesToPoints(0.75)
            .RightMargin = Application.InchesToPoints(0.75)
            .TopMargin = Application.InchesToPoints(1)
            .BottomMargin = Application.InchesToPoints(1)
            .HeaderMargin = Application.InchesToPoints(0.5)
            .FooterMargin = Application.InchesToPoints(0.5)
            .PrintHeadings = False
            .PrintGridlines = False
            .PrintComments = xlPrintNoComments
            .PrintQuality = 600
            .CenterHorizontally = False
            .CenterVertically = False
            .Orientation = xlPortrait
            .Draft = False
            .PaperSize = xlPaperA4
            .FirstPageNumber = xlAutomatic
            .Order = xlDownThenOver
            .BlackAndWhite = False
            .Zoom = False
            .FitToPagesWide = 1
            '        .FitToPagesTall = 100
            .PrintErrors = xlPrintErrorsDisplayed
        End With
    End With

    Application.ScreenUpdating = True
End Sub

Конечно скорость работы сразу падает...

[Омега]

Спасибо за отклик (по поводу информации в подписи разберемся).

Теперь по коду (рассмотрим три последних)
1) отличный вариант, только бы разбить на страницы под печать
2) тоже вариант отличный, но опять возникает вопрос страниц
3) не запустился пишет ошибку и выделяет Sub vizov() желтым цветом

Я бы доработал вариант №2 уж очень он соответствует задаче предоставления информации в последовательном виде.
Единственное, можно сделать так:
Разбить "Просроченные, Текущие и Плановые" на страницы.
т.е. выложить каждый на отдельный лист формата А4 (уменьшение масштаба возможно не менее 80%).
Просроченные войдут в зону A1:М45 (можно расширить)
Текущие попадут в зону A46:М90 (можно расширить)
Плановые попадут в зону A91:М135 (можно расширить)

Ну или как еще объяснить...
Чтобы Просроченные начали формироваться сверху вниз, слева направо (как пишем и читаем) только не выходя за пределы столбца М, можно максимум до О
Далее Текущие в той же последовательности, ну и следом Плановые.

PS: прыгаю, как ребенок от радости увиденного

[Hugo121]

Ну вот опять меняете алгоритм -
Чтобы Просроченные начали формироваться сверху вниз, слева направо (как пишем и читаем) только не выходя за пределы столбца М, можно максимум до О
Например там есть запись
"Расчеты\Копии расчетов для реестра\3 _двери-купе_\3,2 _рамка_\141 C.xls"
она одна тянется почти до M (с умолчательной шириной столбцов).
Высчитывать ещё и это - геморно... Не говоря уж том, что опять переписывать на 90% код, совмещая два в одном
Настройте последний вариант - когда что-то высвечивается жёлтым, то всегда есть сообщение об ошибке - какое оно было?
У меня на Вашем файле никаких ошибок нет.
И в общем последний вариант уже готов для печати - по ширине всё втиснуто на один лист.

В принципе, можно отдельно по видам выводить на листы... Будет время - подумаю.
Но последний (3-й) вариант нужно Вам наладить.

[Омега]

Жаль не знаю Вашего имени (удобнее было бы обращаться).
По вопросу ширины столбца, длины написанного - не заморачивайтесь, это не суть столь важно, есть номер заказа и этого вполне достаточно, остальная информация в нагрузку.
По 3 коду пишет:
compile error:
Sub or Function not defined

[Hugo121]

А, так not defined вероятно потому, что этот вызов живёт только вместе с сводом
Т.е. оба кода должны быть вместе.

P.S. Я Игорь, приятно познакомиться, Омега

[IgorGO]

Игорь, мог бы представиться Альфой Центаврой, у вас с Омегой замечательная переписка наладилась

можете смело переводить ее в персональное русло, с каждым следующим сообщением решение становиться все более индивидуальным и все менее понятным для широкой аудитории форума