Option Explicit

Sub buildReport()
  Dim rowCaption As Variant
  Dim sh As Worksheet, shReport As Worksheet, shTemplate As Worksheet
  Dim iRowsCount As Long, aData() As Variant, aTemplate() As Variant
  Dim i As Long, iCurrRow As Long, dt As Date, num As Integer
  Dim orderOut() As Variant, j As Byte
      
  Application.ScreenUpdating = False
  
  dt = Application.InputBox("Введите дату:", "Ввод даты", Format(Date, "dd.mm.yyyy"), Type:=1)
  num = Application.InputBox("Введите № договора:", "Ввод № договора", Type:=1)
  
    
  rowCaption = Array("Маршрутная бирка.", "Номер детали", "Наименование", _
                     "S", "Марка стали", "План", "Маршрут")
  orderOut = Array(3, 2, 4, 5, 8, 1)
  Set sh = ThisWorkbook.Sheets("БД")
  Set shReport = ThisWorkbook.Sheets("На печать")
  Set shTemplate = ThisWorkbook.Sheets("Шаблон")
  
  If (dt = False) Or (num = False) Then Exit Sub
  ReDim aTemplate(1 To 7)
  aTemplate(1) = "Договор №: " & CStr(num) & " от: " & Format(dt, "dd.mm.yyyy")
  'Call fillTemplate(shTemplate, "Договор №: " & CStr(num) & " от: " & Format(dt, "dd.mm.yyyy"))
  
   Dim dic As Object, sp As Shape
    Set dic = GetShapes(sh, 17)
  
  For Each sp In shReport.Shapes
        sp.Delete
    Next
  
  shReport.Range("A:B").Value = Empty
  shReport.Columns("A:B").Borders.LineStyle = xlNone
  
  sh.Select
  iRowsCount = sh.Cells(Rows.Count, 1).End(xlUp).Row
  aData = Range("A2:H" & iRowsCount)
  iCurrRow = 1
  For i = LBound(aData) To UBound(aData)
    For j = LBound(orderOut) To UBound(orderOut)
      aTemplate(j + 2) = aData(i, orderOut(j))
    Next j
    If dic.Exists(i + 1) Then
        For Each sp In shTemplate.Shapes
            sp.Delete
        Next

        Set sp = dic(i + 1)
        sp.Copy
        shTemplate.Select
        Range("C4").Select
        ActiveSheet.Paste
    End If
    shTemplate.Cells(1, 2).Resize(7, 1).Value = Application.Transpose(aTemplate)
    shTemplate.Range("A1:C7").Copy Destination:=shReport.Range("A" & CStr(iCurrRow))
    iCurrRow = iCurrRow + 8
  Next i
  shReport.Select
  Set sh = Nothing
  Set shTemplate = Nothing
  Set shReport = Nothing
  Erase aData
  Application.ScreenUpdating = True
End Sub

Private Function GetShapes(sh As Worksheet, xCol As Long) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim sp As Shape
    For Each sp In sh.Shapes
        If sp.TopLeftCell.Column = xCol Then
            Set dic(sp.TopLeftCell.Row) = sp
        End If
    Next
    Set GetShapes = dic
End Function

Option Explicit
'Выделите ячейки, запустите макрос "Разделить".
Sub Разделить()
    CloseEmptyWb
    ActiveSheet.Copy
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    SplitRange rr
End Sub

Sub SplitRange(rr As Range)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Dim rArea As Range
    For Each rArea In rr.Areas
        SplitArea rArea
    Next
    
    Application.Calculation = Application_Calculation
    rr.Parent.Parent.Saved = True
    Application.ScreenUpdating = True
End Sub

Sub SplitArea(rr As Range)
    Dim yr As Long
    For yr = rr.Rows.Count To 1 Step -1
        SplitRow rr.Rows(yr)
    Next
End Sub

Sub SplitRow(rr As Range)
    Dim arr As Variant
    If rr.Cells.Count = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    
    Dim brr As Variant, xa As Long, nRow As Long
    nRow = 1
    ReDim brr(1 To UBound(arr, 2))
    For xa = 1 To UBound(brr)
        brr(xa) = Split(arr(1, xa), Chr(10))
        If LBound(brr(xa)) > UBound(brr(xa)) Then brr(xa) = Array(Empty)
        nRow = nRow * (UBound(brr(xa)) - LBound(brr(xa)) + 1)
    Next
    
    Dim yrr As Variant, orr As Variant, yo As Long
    ReDim yrr(1 To UBound(brr)) As Long
    ReDim orr(1 To nRow, 1 To UBound(brr))
    
    Dim xy As Long
    xy = UBound(yrr)
    Do
        If yo = UBound(orr, 1) Then Exit Do
        recu yrr, xy, brr, orr, yo
        DoEvents
    Loop
    If nRow > 1 Then
        rr.Rows(1).EntireRow.Copy
        rr.Rows(2).Resize(nRow - 1).EntireRow.Insert Shift:=xlDown
        Application.CutCopyMode = False
        rr.Resize(UBound(orr, 1), UBound(orr, 2)).Value = orr
    End If
End Sub

Private Sub recu(yrr As Variant, xy As Long, brr As Variant, orr As Variant, yo As Long)
    yo = yo + 1
    FillArrayRow orr, yo, brr, yrr
    
    yrr(xy) = yrr(xy) + 1
    If yrr(xy) > UBound(brr(xy)) Then
        Dim xo As Long
        For xo = xy To UBound(yrr)
            yrr(xo) = LBound(brr(xo))
        Next
        For xo = xy - 1 To LBound(yrr) Step -1
            yrr(xo) = yrr(xo) + 1
            If yrr(xo) <= UBound(brr(xo)) Then Exit For
            yrr(xo) = LBound(brr(xo))
        Next
        
        xy = UBound(yrr)
    End If
End Sub

Private Sub FillArrayRow(orr As Variant, yo As Long, brr As Variant, yrr As Variant)
    Dim xo As Long
    For xo = 1 To UBound(orr, 2)
        orr(yo, xo) = brr(xo)(yrr(xo))
    Next
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit

Sub StructureJob()
    CloseEmptyWb

    Dim rSource As Range
    Set rSource = Intersect(Selection, ActiveSheet.UsedRange)
    
    Dim ca As Range, maxOutlineLevel As Long
    For Each ca In rSource.Columns(1).Cells
        maxOutlineLevel = WorksheetFunction.Max(maxOutlineLevel, ca.EntireRow.OutlineLevel)
    Next
    
    Dim arr As Variant, brr As Variant
    ReDim arr(1 To rSource.Rows.Count, 1 To rSource.Columns.Count + maxOutlineLevel - 1) As Range
    ReDim brr(1 To maxOutlineLevel) As Range
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim rTarget As Range
    Set rTarget = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    rTarget.Resize(, UBound(brr)).EntireColumn.ColumnWidth = rSource.Columns(1).ColumnWidth
    
    Dim xb As Long, xs As Long
    xb = UBound(brr)
    For xs = 2 To rSource.Columns.Count
        xb = xb + 1
        rTarget.Cells(1, xb).EntireColumn.ColumnWidth = rSource.Columns(xs).ColumnWidth
    Next
    
    For Each ca In rSource.Columns(1).Cells
        Set brr(ca.EntireRow.OutlineLevel) = ca
        If ca.EntireRow.OutlineLevel = maxOutlineLevel Then
            For xb = LBound(brr) To UBound(brr)
                brr(xb).Copy rTarget.Cells(1, xb)
            Next
            For xs = 2 To rSource.Columns.Count
                ca.Cells(1, xs).Copy rTarget.Cells(1, xb)
                xb = xb + 1
            Next
            Set rTarget = rTarget.Cells(2, 1)
        ElseIf ca.EntireRow.OutlineLevel = 1 And ca.Cells(2, 1).EntireRow.OutlineLevel = 1 Then
            ca.Cells(1, 1).Copy rTarget.Cells(1, 1)
            Set rTarget = rTarget.Cells(2, 1)
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Sub Копирование()
    'v8
    Dim ya As Long, iEnd As Long, Rng As Range, RngCurrent As Range, RngUsed As Variant, arr As Variant, brr As Variant, aFormula As Variant, kk As Double, xr As Long
    On Error Resume Next
    Set Rng = Selection
    Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub
    If Rng.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = Rng.Value
    Else
        arr = Rng.Value
    End If
    
    Dim shTarget As Worksheet
    Set shTarget = Rng.Parent
    
    brr = Rng.EntireRow.Cells(1, 1).Resize(shTarget.UsedRange.Rows.Count).Value
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    For ya = 1 To UBound(arr, 1)
        If IsNumeric(arr(ya, 1)) Then
'            For iEnd = ya + 1 To UBound(brr, 1)
'                If Not IsEmpty(brr(iEnd, 1)) Then Exit For
'            Next
'            iEnd = iEnd - 1
            iEnd = ya
            If iEnd >= ya Then
                Set RngUsed = Rng.EntireRow.Resize(, Rng.Parent.UsedRange.Columns.Count)
                'sFormula = Rng.Cells(ya, 1).Formula
                aFormula = RngUsed.Formula
                kk = Rng.Cells(ya, 1).Value
                If kk > 0 Then
                    For xr = 1 To RngUsed.Columns.Count
                        If Not IsEmpty(RngUsed.Cells(ya, xr).Value) Then
                            If IsNumeric(RngUsed.Cells(ya, xr).Value) Then
                                RngUsed.Cells(ya, xr).Value = RngUsed.Cells(ya, xr).Value / kk
                            End If
                        End If
                    Next
                End If
                
                Set RngCurrent = Range(Rng.Rows(ya), Rng.Rows(iEnd))
                Set RngCurrent = RngCurrent.EntireRow
                RngCurrent.Copy
                
                With shTarget.UsedRange
                    .Cells(.Rows.Count + 1, 1).Resize(RngCurrent.Rows.Count * arr(ya, 1), 1).Insert Shift:=xlDown
                End With
                'Rng.Cells(ya, 1).Formula = sFormula
                RngUsed.Formula = aFormula
                ya = iEnd
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = Application_Calculation
End Sub

Sub Копирование()
    'v6
    Dim ya As Long, iEnd As Long, Rng As Range, RngCurrent As Range, arr As Variant, brr As Variant, sFormula As String
    On Error Resume Next
    Set Rng = Selection
    Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub
    If Rng.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = Rng.Value
    Else
        arr = Rng.Value
    End If
    
    Dim shTarget As Worksheet
    Set shTarget = Rng.Parent
    
    brr = Rng.EntireRow.Cells(1, 1).Resize(shTarget.UsedRange.Rows.Count).Value
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    For ya = 1 To UBound(arr, 1)
        If IsNumeric(arr(ya, 1)) Then
            For iEnd = ya + 1 To UBound(brr, 1)
                If Not IsEmpty(brr(iEnd, 1)) Then Exit For
            Next
            iEnd = iEnd - 1
            If iEnd >= ya Then
                sFormula = Rng.Cells(ya, 1).Formula
                Rng.Cells(ya, 1).Value = 1
                Set RngCurrent = Range(Rng.Rows(ya), Rng.Rows(iEnd))
                Set RngCurrent = RngCurrent.EntireRow
                RngCurrent.Copy
                
                With shTarget.UsedRange
                    .Cells(.Rows.Count + 1, 1).Resize(RngCurrent.Rows.Count * arr(ya, 1), 1).Insert Shift:=xlDown
                End With
                Rng.Cells(ya, 1).Formula = sFormula
                ya = iEnd
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = Application_Calculation
End Sub