Option Explicit

Sub Материалы()
    Dim rr As Range
    Set rr = Range("A1:F1")
    Set rr = rr.Resize(rr.Parent.UsedRange.Row + rr.Parent.UsedRange.Rows.Count - 1)
    If rr.Rows.Count = 1 Then Exit Sub
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr As Variant, brr As Variant, ya As Long, yb As Long, yc As Long, ye As Long, ym As Long, xa As Long, ss As String
    arr = rr.FormulaR1C1
    ClearArray arr
    ReDim brr(1 To 2 * UBound(arr, 1), 1 To UBound(arr, 2))
    For ya = 1 To UBound(arr, 1)
        If InStr(arr(ya, 1), "Материалы") > 0 Then
            ym = ya
            Exit For
        End If
        
        If Not IsEmpty(arr(ya, 1)) Then
            For ye = ya + 1 To UBound(arr, 1)
                If arr(ye, 1) = "Итого" Then
                    For yc = ya To ye - 1
                        ss = ss & Chr(10) & arr(yc, 1)
                    Next
                    Debug.Print ss
                    If Not dic.Exists(ss) Then
                        dic(ss) = Empty
                        For yc = ya To ye - 1
                            yb = yb + 1
                            For xa = 1 To UBound(arr, 2)
                                brr(yb, xa) = arr(yc, xa)
                            Next
                        Next
                        yb = yb + 1
                    End If
                    ss = ""
                    Exit For
                ElseIf arr(ye, 1) = "" Then
                    Exit For
                End If
            Next
            ya = ye
        End If
    Next
    If ym = 0 Then ym = ya
    If yb = 0 Then Exit Sub
    arr = ResizeArray(brr, yb - 1)
    brr = Empty
    PrintArray arr, rr.Cells(ym + 1, 1)
End Sub

Private Sub PrintArray(arr As Variant, rr As Range)
    Set rr = rr.Resize(UBound(arr, 1), UBound(arr, 2))
    rr.Rows(1).EntireRow.Copy rr.EntireRow
    rr.FormulaR1C1 = arr
End Sub

Private Function ResizeArray(arr As Variant, nRows As Long) As Variant
    Dim brr As Variant
    ReDim brr(1 To nRows, 1 To UBound(arr, 2))
    Dim yb As Long, xb As Long
    For yb = 1 To UBound(brr, 1)
    For xb = 1 To UBound(brr, 2)
        brr(yb, xb) = arr(yb, xb)
    Next
    Next
    ResizeArray = brr
End Function

Private Sub ClearArray(arr As Variant)
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
End Sub