Sub proga()
    Dim i As Long
    Dim objUsedRange As Range
    Set objUsedRange = ThisWorkbook.ActiveSheet.UsedRange
        For i = 2 To objUsedRange.Rows.Count
        With Application.Workbooks.Add
            Union(objUsedRange.Rows(1), objUsedRange.Rows(i)).Copy .ActiveSheet.Cells(1, 1)
     Range("A1:K2").Select
    Selection.Copy
    ActiveWindow.LargeScroll ToRight:=-1
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "????????"
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Arial"
        .FontStyle = "???????"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16777216
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A1:A2").Select
    ActiveWindow.SmallScroll ToRight:=11
    Range("A1:K2").Select
    Selection.ClearContents
    Selection.EntireRow.Delete
    Range("N6").Select
        End With
Set AppWord = CreateObject("Word.Application")
AppWord.Visible = True
AppWord.Documents.Add
ActiveSheet.PageSetup.PrintArea = "$A$1:$B$11"
Columns("A:B").ColumnWidth = 47
Range("A1:B11").Copy
AppWord.Selection.Paste
Application.CutCopyMode = False
Set AppWord = Nothing
    Next
End Sub