Sub crReport()
    Dim reportDate As String
    Dim iCell As Range
    Dim iRow As Integer
    Dim iText As String
    Dim iStNum As Integer
    Dim jText As String
    Dim jStNum As Integer
    Dim iDate As String
    Dim LValue As String
    Dim arrStatTXT As Variant
    arrStatTXT = Array("J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T")
    
    iDate = Date
    Worksheets("Отчет").Cells(3, "D").Value = iDate & " г."
    
    For Each iCell In Range(Worksheets("Заявки").Cells(3, 2), Worksheets("Заявки").Cells(Rows.Count, 2).End(xlUp))
        iRow = iCell.Row + 3
        Worksheets("Отчет").Cells(iRow, 1).Value = Worksheets("Заявки").Cells(iCell.Row, 1).Value
        Worksheets("Отчет").Cells(iRow, "B").Value = "АААА/" & Worksheets("Заявки").Cells(iCell.Row, "H").Value & vbNewLine & "от " & _
                    Worksheets("Заявки").Cells(iCell.Row, "I").Value & " г."
        Worksheets("Отчет").Cells(iRow, "C").Value = Worksheets("Заявки").Cells(iCell.Row, "B").Value
        Worksheets("Отчет").Cells(iRow, "D").Value = Worksheets("Заявки").Cells(iCell.Row, "E").Value & vbNewLine & _
                    Worksheets("Заявки").Cells(iCell.Row, "G").Value & vbNewLine & "по " & _
                    Worksheets("Заявки").Cells(iCell.Row, "F").Value & vbNewLine
        Worksheets("Отчет").Cells(iRow, "G").Value = Worksheets("Заявки").Cells(iCell.Row, "T").Value
        iText = ""
        iStNum = 0
        For iTXT = LBound(arrStatTXT) To UBound(arrStatTXT)
            If Worksheets("Заявки").Cells(iCell.Row, arrStatTXT(iTXT)).Interior.ColorIndex <> xlNone Then
                iStNum = iStNum + 1
                iText = iText & iStNum & ". " & Worksheets("Заявки").Cells(iCell.Row, arrStatTXT(iTXT)).Value & vbNewLine
            End If
        Next iTXT
        Worksheets("Отчет").Cells(iRow, "E").Value = iText
        jText = ""
        jStNum = 0
        For jTXT = LBound(arrStatTXT) To UBound(arrStatTXT)
            If Worksheets("Заявки").Cells(iCell.Row, arrStatTXT(jTXT)).Font.Color <> 0 Then
                jStNum = jStNum + 1
                jText = jText & jStNum & ". " & Worksheets("Заявки").Cells(iCell.Row, arrStatTXT(jTXT)).Value & vbNewLine
            End If
        Next jTXT
        Worksheets("Отчет").Cells(iRow, "F").Value = jText
    Next
    Call CreateWord
End Sub
Sub CreateWord()
    Debug.Print "Создаем Word!"
    Dim fData As String
    Dim objWord As Object
    Dim wPath As String
    
    fData = Format(Date, "yyyy/mm/dd")
    
    Set wa = CreateObject("Word.Application")
    wa.Visible = True
    wPath = ActiveWorkbook.Path & "\Форма_отчета.dotx"
    Set objWord = wa.Documents.Add(wPath)

    Range(Worksheets("Отчет").Cells(5, 1), Worksheets("Отчет").Cells(Rows.Count, "G").End(xlUp)).Copy
    objWord.Bookmarks("Дата_Отчета").Range.Text = Worksheets("Отчет").Cells(3, "D").Value
    objWord.Bookmarks("Таблица_Отчета").Range.Paste
    'With .Tables(1)
    '       .Rows.HeightRule = 2 'wdRowHeightExactly
    '        For i = 1 To Selection.Cells.Count
    '            .Rows(i).Height = Rows(i).Height
    '            .Range.Font.Name = "Times New Roman"
    '        Next
    ' End With
    objWord.SaveAs FileName:=ActiveWorkbook.Path & "\" & fData & "__Отчет.docx"
    
    objWord.Close True
    wa.Quit
    Set wa = Nothing
        
End Sub