Public Sub Forming_Svodnaia_Table()
Dim strWorkbookName As String
Dim xlWorkbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rng As Range
Dim lngRow As Long
Dim intNumberProb As Integer
Dim lngBeginIngredientRow As Long
Dim lngRowInSvod_Tabl As Long
Dim lngBeginNextIngredientRow As Long
Dim lngNumberFreeRow As Long
Dim intCountSheets As Integer
Dim lngEndHeadIngredientRow As Long
Dim lngHeadIngredientRow As Long
Dim lngRowForIngredient As Long
Dim lngInsertRow As Long
Dim intCountInsert As Integer
Dim blnExitFor As Boolean

On Error GoTo ErrorHandler

    strWorkbookName = ThisWorkbook.Name
    Set xlWorkbook = Application.Workbooks(strWorkbookName)
    Set xlSheet = xlWorkbook.Worksheets("протокол")
    
    'определяем количество проб (на листе 'протокол')
    For lngRow = 9 To 65536
        If Len(xlSheet.Cells(lngRow, 2).Value) = 0 Then
            intNumberProb = xlSheet.Cells(lngRow - 1, 2).Value
            Exit For
        End If
    Next
    
    Application.ScreenUpdating = False
    
    'теперь работаем с листом 'свод_табл'
    Set xlSheet = xlWorkbook.Worksheets("свод_табл")
    xlSheet.Unprotect "1"
    'продвигаемся по первому столбцу и натыкаемся на очередной ингредиент
    blnExitFor = False
    For lngRowInSvod_Tabl = 1 To 65536
        
        If xlSheet.Cells(lngRowInSvod_Tabl, 1).Value = "e" Then Exit For  'дошли до ячейки 'e' (end)
        
        If xlSheet.Cells(lngRowInSvod_Tabl, 1).Interior.ColorIndex = 37 Then
            lngBeginIngredientRow = lngRowInSvod_Tabl 'начало очередного ингредиента
            gstrSheetName = xlSheet.Cells(lngRowInSvod_Tabl, 1).Value  'его название
            'узнаем размер блока, который занимает этот ингредиент
            Call SizeBlock(gstrSheetName)
            
            'но поскольку в фотометрических методиках 2 правых столбца не нужны, уменьшим для них значение правой границы на 2
            Select Case gstrSheetName
                Case "NH4 (Ф)", "NO3 (Ф)", "NO2 (Ф)", "PO4 (Ф)", "Fe (Ф)", "Cu (Ф)", "Mn (Ф)", "Cr (Ф)", "SO4 (Тб)"
                    mintColumnsInBlock = mintColumnsInBlock - 2
            End Select
            
            
            'определяем начало следующего за ним ингредиента
            For lngRow = lngBeginIngredientRow + 1 To 65536
                Rem If Len(xlSheet.Cells(lngRow, 1).Value) <> 0 Then 'начало следующего за ним ингредиента
                If xlSheet.Cells(lngRow, 1).Value = "e" Then blnExitFor = True
                
                If xlSheet.Cells(lngRow, 1).Interior.ColorIndex = 37 Or xlSheet.Cells(lngRow, 1).Value = "e" Then 'начало следующего за ним ингредиента
                    lngBeginNextIngredientRow = lngRow
                    Exit For
                End If
            Next
            
            'определяем количество строк до следующего за ним ингредиента
            lngNumberFreeRow = lngBeginNextIngredientRow - lngBeginIngredientRow - 1
            
            'очищаем эти строки, если там что-то есть
            If lngNumberFreeRow > 4 Then
                Set rng = xlSheet.Range(xlSheet.Cells(lngBeginIngredientRow + 1, 1), xlSheet.Cells(lngBeginNextIngredientRow - 4, 256))
                rng.Delete shift:=xlUp
                'переопределяем значение числа свободных строк
                lngNumberFreeRow = lngBeginNextIngredientRow - lngBeginIngredientRow - lngNumberFreeRow + 2
            End If
            
           
            'теперь работаем с конкретным листом
            Set xlSheet = xlWorkbook.Worksheets(gstrSheetName)
            
            'определяем количество строк, занимаемое "шапкой" (от 2 строки до строки, где находится № п/п пробы = 1)
            For lngRow = 2 To 65536
                If xlSheet.Cells(lngRow, 2).Value = 1 Then
                    lngEndHeadIngredientRow = lngRow
                    Exit For
                End If
            Next
            
            lngHeadIngredientRow = lngEndHeadIngredientRow - 2  'количество строк, занимаемое "шапкой"
            lngRowForIngredient = lngHeadIngredientRow + (mintRowsInBlock + 1) * intNumberProb 'число строк, требуемое для размещения ингредиента
            
            'вычисляем сколько строк требуется воткнуть
            lngInsertRow = lngRowForIngredient - lngNumberFreeRow
                                
            'возвращаемся на сводную таблицу и втыкаем нужное количество строк в нужное место
            Set xlSheet = xlWorkbook.Worksheets("свод_табл")
            
            For intCountInsert = 1 To lngInsertRow + 6 'втыкать будем столько раз, сколько недостает строк (+ 6 - на отступ)
                'выделяем строку и вставляем строку перед ней
                Set rng = xlSheet.Range(xlSheet.Cells(lngBeginIngredientRow + 2, 1), xlSheet.Cells(lngBeginIngredientRow + 2, 256))
                rng.Cells.Copy
                rng.Cells.Insert shift:=xlDown  'ВОТ ЭТО - УЗКОЕ МЕСТО

            Next
            
            
            'место подготовлено - можно копировать
            Set xlSheet = xlWorkbook.Worksheets(gstrSheetName)
            
            Set rng = xlSheet.Range(xlSheet.Cells(2, 1), xlSheet.Cells(lngRowForIngredient + 1, mintColumnsInBlock))  'выделяем все, что
                                                                                                    'занимает ингредиент на своем листе
            rng.Cells.Copy  'копируем
            
            
            Set xlSheet = xlWorkbook.Worksheets("свод_табл")
            
            Set rng = xlSheet.Range(xlSheet.Cells(lngBeginIngredientRow + 2, 1), _
                xlSheet.Cells(lngBeginIngredientRow + lngRowForIngredient + 1, mintColumnsInBlock)) 'выделяем место для копирования
            rng.Cells.Insert shift:=xlShiftToRight   'вставляем в него скопированное
            
            'но теперь удалим ячейки, из-за которых сдвинулся столбец сортировки
            Set rng = xlSheet.Range(xlSheet.Cells(lngBeginIngredientRow + 2, mintColumnsInBlock + 1), _
                xlSheet.Cells(lngBeginIngredientRow + lngRowForIngredient + 1, mintColumnsInBlock * 2))
            rng.Cells.Delete shift:=xlShiftToLeft
            
            Rem rng.Columns.AutoFit
            
            xlSheet.Range(xlSheet.Cells(lngBeginIngredientRow + 2, 1), _
                xlSheet.Cells(lngBeginIngredientRow + lngRowForIngredient + 1, mintColumnsInBlock)).EntireRow.AutoFit   'подгоняем высоту строки под содержимое
            Rem xlSheet.Range(xlSheet.Cells(lngBeginIngredientRow + 2, 1), _
                xlSheet.Cells(lngBeginIngredientRow + lngRowForIngredient + 1, mintColumnsInBlock)).EntireColumn.AutoFit
            Application.CutCopyMode = False 'убираем выделение
            Rem xlsheet.Protect "1"
                        
        End If
        
        If blnExitFor Then Exit For
        
    Next
    
    Application.ScreenUpdating = True
    
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    Application.ScreenUpdating = True
    MsgBox "Forming_Svodnaia_Table " & gstrSheetName & " Ошибка №:" & Err.Number & ";Описание:" & Err.Description
    Resume ErrorHandlerExit
End Sub