'Этот макрос для копирования данных. (на самом деле он тупо копирует строки которые являются голубыми или не такими как все)
Option Explicit

Sub InsRow()
'объявляем непонятные переменные
    Dim lrow&, numgr$, i&, clarr$(), rowarr$(), arr(), arr1
    Dim objDic As Object, ikey, j&
    Dim m As String
    Dim k As Variant
    'создаем директорию
    Set objDic = CreateObject("scripting.dictionary")
    'макрос работает с двумя листами shtout и shtin (наверное по этой причине они так и переименнованы в данной книге) P.S. возможно они могут работать если в With прописать "Лист 1" и _
    "Лист 2" соответственно, но это не точно.
    With Лист1
    'первый лист предполагает наличие 2р
        lrow = .Range("a" & .Rows.Count).End(xlUp).Row
        For i = 1 To lrow
            Debug.Print
            'Что-то типа если текущая ячейка удовлетворяет условию "1.* (и все что после)" тогда это номер группы
            If .Cells(i, 1).Value Like "1.*" Then numgr = .Cells(i, 1).Value
            'если мы нашли ячейку с голубым не таким как все цветом, и данная ячейка не равна группвой, тогда что-то типа мы записываем ее в объект группы
            If .Range("a" & i).Font.Color <> 0 And .Range("a" & i).Value <> numgr Then
            '.Cells(i, 1 можно поменять столбец с которого будет копироваться информация)
                objDic.Item(numgr) = objDic.Item(numgr) & .Cells(i, 1) & "||" & .Cells(i, 3) & "|||" & .Cells(i, 33) & "^"
            End If
        Next i
    End With
    'это второй лист, который является нашим основным
    With Лист2
    ' тут мы указываем какой диапазон, или грубо говоря номер последней рабочей ячейки в столбце
        lrow = .Range("a" & .Rows.Count).End(xlUp).Row
        'мы идем в обратном направлении
        For i = lrow To 1 Step -1
        'тут меняя цифру можно указать какой столбец мы используем для поиска группы
            numgr = .Cells(i, 1)
            
            If objDic.exists(numgr) Then
            
                clarr = Split(objDic.Item(numgr), "^")
                ReDim arr(1 To UBound(clarr), 2)
                j = 1
                For Each ikey In clarr
                    If ikey <> "" Then
                        arr(j, 0) = Split(ikey, "||", 2)(0)
                        arr(j, 1) = Split(Split(ikey, "||", 2)(1), "|||", 2)(0)
                        arr(j, 2) = Split(ikey, "|||", 2)(1)
                        j = j + 1
                    End If
                Next ikey
                'Вставляем строку после нужной   нам группы
                .Rows(i + 1).Resize(UBound(clarr)).Rows.Insert
                '.Cells(i + 1, 1 - меняя это число выбираем столбец куда вставлять)
                'Вставляем значения по первому листу
                For k = 1 To UBound(clarr)
                .Cells(i + k, 1) = arr(k, 0)
                .Cells(i + k, 2) = arr(k, 1)
                .Cells(i + k, 7) = arr(k, 2)
                .Cells(i + k, 13) = arr(k, 2)
                Next k
                'Вставляем значения по второму листу
               ' .Cells(i + 1, 14) = arr(1, 2)
               ' .Cells(i + 1, 20) = arr(1, 2)                            
            End If
        Next i
    End With
    MsgBox "Готово!"
End Sub

.Cells(i + k, 13) = arr(k, 2)

Dim m as String 
m = arr(k, 2)
.Cells(i + k, 13) = m