Sub обработка()
    ' Диалоговое окно для выбора файла Excel
    Dim excelFilePath As String
    Dim i As Long
    Dim tblRange As Excel.Range


MsgBox ("Это снова я - твой помощник и мы начинаем" & vbCrLf & "Сейчас Вас система попросит выбрать файл Word, где хранится шаблон файла")





    ' Диалоговое окно для выбора файла шаблона Word
    Dim wordFilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите файл шаблона Word"
        .Filters.Clear
        .Filters.Add "Word Documents", "*.docx"
        .AllowMultiSelect = False
        If .Show = -1 Then
            wordFilePath = .SelectedItems(1)
        Else
            MsgBox "Файл не выбран. Макрос завершен."
            Exit Sub
        End If
    End With

    On Error Resume Next
    Dim objWrdApp As Object
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0 ' Включить стандартную обработку ошибок обратно

    objWrdApp.Visible = True
    Dim objWrdDoc As Object
    Set objWrdDoc = objWrdApp.Documents.Open(wordFilePath)

iNomer = ThisWorkbook.Worksheets("Лист1").Cells(6, 1)

        ' Обновление закладок в Word данными из Excel
        With objWrdDoc
            .Bookmarks("Bookmark1").Range.Text = ThisWorkbook.Worksheets("Лист1").Cells(1, 2).Value
            .Bookmarks("Bookmark2").Range.Text = ThisWorkbook.Worksheets(iNomer).Cells(12, 4).Value
            .Bookmarks("Bookmark3").Range.Text = ThisWorkbook.Worksheets(iNomer).Cells(12, 5).Value
            .Bookmarks("Bookmark4").Range.Text = ThisWorkbook.Worksheets(iNomer).Cells(12, 6).Value


            ThisWorkbook.Sheets("Список ЛПУ").Range("A1:K1").AutoFilter Field:=6, Criteria1:="ПОЛИКЛИНИКА"
            ThisWorkbook.Sheets("Список ЛПУ").Range("A1:K1").AutoFilter Field:=3, Criteria1:=ThisWorkbook.Worksheets("Лист1").Cells(2, 1).Value
            ThisWorkbook.Sheets("Список ЛПУ").Range("A1:K1").AutoFilter Field:=5, Criteria1:=ThisWorkbook.Worksheets("Лист1").Cells(3, 1).Value

            ' Копирование отфильтрованных данных из Excel в Word

            'Находим последнюю строку на листе с данными
            lastRow = ThisWorkbook.Sheets("Список ЛПУ").Cells(ThisWorkbook.Sheets("Список ЛПУ").Rows.Count, "A").End(xlUp).Row

            ' Проверяем, применены ли фильтры и есть ли видимые строки после заголовка
            If ThisWorkbook.Sheets("Список ЛПУ").AutoFilterMode And ThisWorkbook.Sheets("Список ЛПУ").FilterMode Then
                ' Получаем диапазон видимых ячеек в столбцах 9 и 10 (I и J)
                'с учетом заголовка
                On Error Resume Next
                Set rngToCopy = ThisWorkbook.Sheets("Список ЛПУ").Range("I1:J" & lastRow).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0

                If rngToCopy Is Nothing Then
                    MsgBox "Нет данных, соответствующих критериям фильтра.", vbInformation
                    'Удаляем фильтры
                    On Error Resume Next
                    ThisWorkbook.Sheets("Список ЛПУ").ShowAllData
                    On Error GoTo 0
                    Exit Sub
                End If

                ' Копируем отфильтрованный диапазон
                rngToCopy.Copy

                ' Вставляем скопированные данные в Word (с сохранением форматирования)

                On Error Resume Next ' Обработка случая, когда закладка может не существовать
                Set PasteRange = objWrdDoc.Bookmarks("Bookmark5").Range
                On Error GoTo 0

                If PasteRange Is Nothing Then
                    MsgBox "Закладка 'Bookmark5' не найдена в Word-документе.", vbCritical
                    'Удаляем фильтры
                    On Error Resume Next
                    ThisWorkbook.Sheets("Список ЛПУ").ShowAllData
                    On Error GoTo 0
                    Exit Sub
                End If

                PasteRange.PasteExcelTable _
                                        LinkedToExcel:=False, _
                                        WordFormatting:=False, _
                                        RTF:=False


                Application.CutCopyMode = False 'Очистка буфера обмена
            Else
                MsgBox "Фильтры не применены или нет видимых данных после применения фильтров.", vbInformation
            End If

            'Удаляем фильтры
            On Error Resume Next
            ThisWorkbook.Sheets("Список ЛПУ").ShowAllData
            On Error GoTo 0

  End With

  'Очистка переменных
    Dim objWS As Object, objWB As Object, objExcel As Object
    Set objWS = Nothing
    Set objWB = Nothing
    Set objExcel = Nothing
    Set objWrdDoc = Nothing
    Set objWrdApp = Nothing
    Set PasteRange = Nothing
    Set rngToCopy = Nothing

  MsgBox "Данные успешно скопированы в Word!", vbInformation


MsgBox ("Ну я все сделал с этим файлом! До новых встреч")

End Sub

Sub ConvertGroupedDataToTable()

  Dim ws As Worksheet
  Dim lastRow As Long
  Dim i As Long, j As Long
  Dim groupLevel As Integer
  Dim outputRow As Long
  Dim outputColumn As Integer
  Dim headers() As String
  Dim headerCount As Integer
  Dim currentHeaderValues() As Variant
  Dim lastColumn As Integer

  ' Укажите лист, содержащий сгруппированные данные
  Set ws = ThisWorkbook.Sheets("Sheet1") ' Измените "Sheet1" на имя вашего листа

  ' Определите последнюю строку с данными
  lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

  ' Определите максимальный уровень группировки (предполагаем, что он равен кол-ву отступов)
  groupLevel = 0
  For i = 1 To lastRow
    If ws.Cells(i, 1).IndentLevel > groupLevel Then
      groupLevel = ws.Cells(i, 1).IndentLevel
    End If
  Next i

  ' Инициализация массивов
  ReDim headers(1 To groupLevel + 1) ' +1 для колонки с товаром
  ReDim currentHeaderValues(1 To groupLevel)
  headerCount = groupLevel + 1

  ' Определите заголовки столбцов (названия уровней группировки)
  For j = 1 To groupLevel
    headers(j) = j & " группировка"
  Next j
  headers(groupLevel + 1) = groupLevel + 1 & " группировка"

  ' Создайте заголовки в новом листе
  Dim outputSheet As Worksheet
  Set outputSheet = ThisWorkbook.Sheets.Add
  outputSheet.Name = "Таблица для сводной"

  For j = 1 To headerCount
    outputSheet.Cells(1, j).Value = headers(j)
  Next j

  ' Инициализируем номер строки для вывода
  outputRow = 2

  ' Пройдитесь по каждой строке исходных данных
  Dim currentGroup(1 To 5) As String ' Массив для хранения значений группировок
  Dim groupIndex As Integer

  For i = 1 To lastRow

    ' Определите уровень группировки текущей строки
    Dim currentLevel As Integer
    currentLevel = ws.Cells(i, 1).IndentLevel + 1 ' уровень отступа +1

    ' Если это не строка с подсуммой/итогом
    If Not ws.Cells(i, 1).Font.Bold Then

      ' Записываем значение в нужную колонку
      outputSheet.Cells(outputRow, currentLevel).Value = ws.Cells(i, 1).Value

      ' Заполняем пустые ячейки справа пробелами
      lastColumn = 5 ' Указываем номер последней колонки
      For j = currentLevel + 1 To lastColumn
        outputSheet.Cells(outputRow, j).Value = ""
      Next j

      ' Если уровень отступа = 0, то это новая строка
      If currentLevel = 1 Then
          outputRow = outputRow + 1
      End If
    End If

  Next i

  MsgBox "Преобразование завершено.  Сводная таблица готова на листе '" & outputSheet.Name & "'."

End Sub

Sub ConvertGroupedDataToTable()

  Dim ws As Worksheet
  Dim lastRow As Long
  Dim i As Long, j As Long
  Dim groupLevel As Integer
  Dim outputRow As Long
  Dim outputColumn As Integer
  Dim headers() As String
  Dim headerCount As Integer
  Dim currentHeaderValues() As Variant

  ' Укажите лист, содержащий сгруппированные данные
  Set ws = ThisWorkbook.Sheets("Sheet1") ' Измените "Sheet1" на имя вашего листа

  ' Определите последнюю строку с данными
  lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

  ' Определите максимальный уровень группировки (предполагаем, что он равен кол-ву отступов)
  groupLevel = 0
  For i = 1 To lastRow
    If ws.Cells(i, 1).IndentLevel > groupLevel Then
      groupLevel = ws.Cells(i, 1).IndentLevel
    End If
  Next i

  ' Инициализация массивов
  ReDim headers(1 To groupLevel + 1) ' +1 для колонки с товаром
  ReDim currentHeaderValues(1 To groupLevel)
  headerCount = groupLevel + 1

  ' Определите заголовки столбцов (названия уровней группировки)
  For j = 1 To groupLevel
    headers(j) = "Уровень " & j ' Можно изменить на что-то более осмысленное
  Next j
  headers(groupLevel + 1) = "Товар"

  ' Создайте заголовки в новом листе
  Dim outputSheet As Worksheet
  Set outputSheet = ThisWorkbook.Sheets.Add
  outputSheet.Name = "Таблица для сводной"

  For j = 1 To headerCount
    outputSheet.Cells(1, j).Value = headers(j)
  Next j

  ' Инициализируем номер строки для вывода
  outputRow = 2

  ' Пройдитесь по каждой строке исходных данных
  For i = 1 To lastRow

    ' Определите уровень группировки текущей строки
    Dim currentLevel As Integer
    currentLevel = ws.Cells(i, 1).IndentLevel

    ' Если это не строка с подсуммой/итогом
    If Not ws.Cells(i, 1).Font.Bold Then

      ' Обновите значения заголовков для текущего уровня и выше
      For j = 1 To currentLevel
        currentHeaderValues(j) = ws.Cells(i, 1).Value
      Next j

      ' Если текущий уровень - максимальный (т.е. это "Товар")
      If currentLevel = groupLevel Then

        ' Запишите данные в выходной лист
        For j = 1 To groupLevel
          outputSheet.Cells(outputRow, j).Value = currentHeaderValues(j)
        Next j
        outputSheet.Cells(outputRow, groupLevel + 1).Value = ws.Cells(i, 1).Value ' Значение товара

        ' Переходим к следующей строке для вывода
        outputRow = outputRow + 1

      End If

    End If

  Next i

  MsgBox "Преобразование завершено.  Сводная таблица готова на листе '" & outputSheet.Name & "'."

End Sub

  ' Делаем ФИО жирным в столбце C.
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        searchString = ThisWorkbook.Sheets(1).Cells(i, 1).Value  ' ФИО из столбца А

        'Определяем позицию начала ФИО в ячейке С
        Dim startPos As Long
        startPos = InStr(1, ThisWorkbook.Sheets(1).Cells(i, 3).Value, vbLf & searchString)

        'Если ФИО обнаружено в ячейке С
        If startPos > 0 Then
            With ThisWorkbook.Sheets(1).Cells(i, 3).Characters(startPos, Len(searchString)).Font
                .Bold = True
            End With
        End If
    Next i


    MsgBox "Обработка завершена."
       
        
    MsgBox ("Это снова я - твой помощник и мы продолжаем" & vbCrLf & "Сейчас Вас система попросит выбрать файл Word, где хранится шаблон наклеек")

    ' Диалоговое окно для выбора файла шаблона Word
    Dim wordFilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите файл шаблона Word"
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc"
        .AllowMultiSelect = False
        If .Show = -1 Then
            wordFilePath = .SelectedItems(1)
        Else
            MsgBox "Файл не выбран. Макрос завершен."
            Exit Sub
        End If
    End With

    On Error Resume Next
    Dim objWrdApp As Object
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0 ' Включить стандартную обработку ошибок обратно

    objWrdApp.Visible = True
    Dim objWrdDoc As Object
    Set objWrdDoc = objWrdApp.Documents.Open(wordFilePath)


    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    l = l + 1
        ' Обновление закладок в Word данными из Excel
        With objWrdDoc
            .Bookmarks("Bookmark_2").Range.Text = Cells(i, 3).Value
            .Bookmarks("Bookmark_3").Range.Text = Cells(i + 1, 3).Value
            .Bookmarks("Bookmark_4").Range.Text = Cells(i + 2, 3).Value
            .Bookmarks("Bookmark_5").Range.Text = Cells(i + 3, 3).Value
            .Bookmarks("Bookmark_6").Range.Text = Cells(i + 4, 3).Value
            .Bookmarks("Bookmark_7").Range.Text = Cells(i + 5, 3).Value
            .Bookmarks("Bookmark_8").Range.Text = Cells(i + 6, 3).Value

            .Bookmarks("Bookmark_9").Range.Text = Cells(i + 7, 3).Value
            .Bookmarks("Bookmark_10").Range.Text = Cells(i + 8, 3).Value
            .Bookmarks("Bookmark_11").Range.Text = Cells(i + 9, 3).Value
            .Bookmarks("Bookmark_12").Range.Text = Cells(i + 10, 3).Value
            .Bookmarks("Bookmark_13").Range.Text = Cells(i + 11, 3).Value
            .Bookmarks("Bookmark_14").Range.Text = Cells(i + 12, 3).Value
            .Bookmarks("Bookmark_15").Range.Text = Cells(i + 13, 3).Value
            .Bookmarks("Bookmark_16").Range.Text = Cells(i + 14, 3).Value
            .Bookmarks("Bookmark_17").Range.Text = Cells(i + 15, 3).Value
        End With

   ' Очистка содержимого
    Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    
    

   [C2].Resize(Cells(Rows.Count, "A").End(xlUp).Row - 1, 1).FormulaR1C1 = _
        "=RC[-2]&CHAR(10)&REPLACE(RC[-1],1,IFERROR(FIND("" ул."",RC[-1]),IFERROR(FIND("" пр-кт"",RC[-1]),IFERROR(FIND("" б-р"",RC[-1]),IFERROR(FIND("" пер"",RC[-1]),IFERROR(FIND("" наб."",RC[-1]),1))))),"""")&CHAR(10)&REPLACE(LEFT(RC[-1],FIND("","",RC[-1])-1),1,7,)&CHAR(10)&LEFT(RC[-1],6)"
        
        
   ' Преобразование формулы в значения
    With Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
        .Value = .Value
    End With

    ' Делаем ФИО жирным в столбце C.
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        searchString = ThisWorkbook.Sheets(1).Cells(i, 1).Value  ' ФИО из столбца А

        'Определяем позицию начала ФИО в ячейке С
        Dim startPos As Long
        startPos = InStr(1, ThisWorkbook.Sheets(1).Cells(i, 3).Value, searchString)

        'Если ФИО обнаружено в ячейке С
        If startPos > 0 Then
            With ThisWorkbook.Sheets(1).Cells(i, 3).Characters(startPos, Len(searchString)).Font
                .Bold = True
            End With
        End If
    Next i


    MsgBox "Обработка завершена."

        
        
    MsgBox ("Это снова я - твой помощник и мы продолжаем" & vbCrLf & "Сейчас Вас система попросит выбрать файл Word, где хранится шаблон наклеек")





    ' Диалоговое окно для выбора файла шаблона Word
    Dim wordFilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите файл шаблона Word"
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc"
        .AllowMultiSelect = False
        If .Show = -1 Then
            wordFilePath = .SelectedItems(1)
        Else
            MsgBox "Файл не выбран. Макрос завершен."
            Exit Sub
        End If
    End With

    On Error Resume Next
    Dim objWrdApp As Object
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0 ' Включить стандартную обработку ошибок обратно

    objWrdApp.Visible = True
    Dim objWrdDoc As Object
    Set objWrdDoc = objWrdApp.Documents.Open(wordFilePath)


    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    l = l + 1
        ' Обновление закладок в Word данными из Excel
        With objWrdDoc
            .Bookmarks("Bookmark_2").Range.Text = Cells(i, 3).Value
            .Bookmarks("Bookmark_3").Range.Text = Cells(i + 1, 3).Value
            .Bookmarks("Bookmark_4").Range.Text = Cells(i + 2, 3).Value
            .Bookmarks("Bookmark_5").Range.Text = Cells(i + 3, 3).Value
            .Bookmarks("Bookmark_6").Range.Text = Cells(i + 4, 3).Value
            .Bookmarks("Bookmark_7").Range.Text = Cells(i + 5, 3).Value
            .Bookmarks("Bookmark_8").Range.Text = Cells(i + 6, 3).Value

            .Bookmarks("Bookmark_9").Range.Text = Cells(i + 7, 3).Value
            .Bookmarks("Bookmark_10").Range.Text = Cells(i + 8, 3).Value
            .Bookmarks("Bookmark_11").Range.Text = Cells(i + 9, 3).Value
            .Bookmarks("Bookmark_12").Range.Text = Cells(i + 10, 3).Value
            .Bookmarks("Bookmark_13").Range.Text = Cells(i + 11, 3).Value
            .Bookmarks("Bookmark_14").Range.Text = Cells(i + 12, 3).Value
            .Bookmarks("Bookmark_15").Range.Text = Cells(i + 13, 3).Value
            .Bookmarks("Bookmark_16").Range.Text = Cells(i + 14, 3).Value
            .Bookmarks("Bookmark_17").Range.Text = Cells(i + 15, 3).Value
        End With

    Dim objWrdApp As Object
    Dim objWrdDoc As Object
    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
        If objWrdApp Is Nothing Then
            Set objWrdApp = CreateObject("Word.Application")
            Set objWrdDoc = objWrdApp.Documents.Open("C:\Users\Homecomputer\Desktop\Макрос\Doc1.docx")
            objWrdApp.Visible = True
        End If
    Set objWrdDoc = objWrdApp.Documents.Open("C:\Users\Homecomputer\Desktop\Макрос\Doc1.docx")
    Set objWrdDoc = Nothing
    Set objWrdApp = Nothing
    objWrdDoc.SaveAs "C:\Users\Homecomputer\Desktop\Макрос\Doc2.docx"

[C2].Resize(Cells(Rows.Count, "A").End(xlUp).Row - 1, 1).FormulaR1C1 = "=A1&CHAR(10)&REPLACE(B1;1;FIND("" улица"";B1)&CHAR(10)&REPLACE(LEFT(B1;FIND("","";B1)-1);1;7;)&CHAR(10)&LEFT(B1;6)"