Sub Создание_Наклеек()
Dim i&, i_n&, j&
Dim f$(), f1(), a(), s$, leghtstr&, cel$
Dim ACTWB As Workbook, Path_1$
Dim c&
   Dim oWord As Object
   Dim oDocument As Object
   Dim Name$, Path_$
   Dim n&
   Dim t As Object
   Dim r As Range
   Dim k&, k1&
   Dim par As Object
   Dim InputPath$
c = InputBox("С какого по счету шильда?", _
"Начинать с...", "1") ' тот по счету шильдик, с которого начинаем печатать
Set ACTWB = ThisWorkbook
Path_1 = ACTWB.Path & "\"
InputPath = Path_1 & "Наклейки на шкаф (Серые)" & ".doc" 'путь сохранения (с именем файла)
i_n = Cells(Rows.Count, 1).End(xlUp).Row
ReDim f(i_n)
ReDim f1(i_n)
If Cells(2, 2) = "" Then
   flg1 = True
End If
For i = 1 To i_n
'  f(i) = Cells(i, 1).Value
  cel = Cells(i, 1)
  leghtstr = Len(cel)
  If flg1 Then
     ReDim a(2, leghtstr)
     For i1 = 1 To leghtstr
        a(1, i1) = Mid(cel, i1, 1)
        a(2, i1) = Cells(i, 1).Characters(i1, 1).Font.Size
     Next i1
  Else
     ReDim a(2, 1)
     a(1, 1) = cel
     a(2, 1) = Cells(2, 2)
  End If
  f1(i) = a
Next i
   If i_n > 27 - c + 1 Then
      
      n = Application.RoundUp((i_n - (27 - c + 1)) / 27, 0)
   End If
   Set Wd = ActiveSheet.Shapes("Шаблон").DrawingObject.Object
   Wd.SaveAs (InputPath)
   Set oWord = CreateObject("Word.Application")
   oWord.Visible = True
   Set oDocument = oWord.Documents.Open(InputPath, ReadOnly:=False)
   oWord.Selection.WholeStory
   oWord.Selection.Copy
   oWord.Selection.EndKey Unit:=6
   For i = 1 To n
       oWord.Selection.InsertBreak Type:=2 '2'7
       oWord.Selection.Paste
   Next
   For Each t In oDocument.Tables
      For i = 1 To t.Rows.Count
         For j = 1 To t.Columns.Count
            If j Mod 2 <> 0 Then
               t.Cell(i, j) = ""
               k1 = k1 + 1
               If k1 >= c Then
                  k = k + 1
                  If k <= i_n Then
''''''''''''''''''''''''''
                     If flg1 Then
                         For i1 = 1 To UBound(f1(k), 2)
                            s = s & f1(k)(1, i1)
                         Next i1
                         t.Cell(i, j) = s
                         For i1 = 1 To UBound(f1(k), 2)
                            t.Cell(i, j).Range.Characters.Item(i1).Font.Size = f1(k)(2, i1)
                         Next i1
                         s = ""
                     Else
                         t.Cell(i, j) = f1(k)(1, 1)
                         t.Cell(i, j).Range.Font.Size = f1(k)(2, 1)
                     End If
''''''''''''''''''''''''''
                  End If
               End If
            End If
         Next j
      Next i
   Next t
   Set par = oDocument.Paragraphs(oDocument.Paragraphs.Count)
   par.Range.Delete
   oDocument.Save
End Sub