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