Range("A2").Resize(a, 7).Value = mass()

Sub fltbl()Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim mass()
lr = ActiveSheet.UsedRange.Rows.Count
lc = ActiveSheet.UsedRange.Columns.Count
ReDim mass(1 To (lr - 3) * (lc - 5), 1 To 7) ' lr-3 - минус 3 первые строки шапки, lc-5 - марки с 6-го столбца, поэтому -5
n = 3 'номер первой строки с названиями марок
For i = 4 To lr ' с четвертой строки начинаем сбор данных
    If Cells(i, 3).Value = "" Then
     n = i 'следующая строка с марками, когда в третьем столбце пусто
    Else
    For j = 6 To lc Step 2 ' марки с 6-го столбца
     If Cells(n, j).Value <> "" Then
      a = a + 1
      mass(a, 1) = Cells(i, 1).Value: mass(a, 2) = Cells(i, 2).Value
      mass(a, 3) = Cells(i, 3).Value: mass(a, 4) = Cells(i, 4).Value
      mass(a, 5) = Cells(i, 5).FormulaLocal: mass(a, 6) = Cells(n, j).Value
      mass(a, 7) = Cells(i, j).FormulaLocal
     End If
    Next
    End If
Next
Worksheets.Add
For i = 2 To a + 1
     For j = 1 To 7
        If j = 5 Or j = 7 Then
           Cells(i, j).FormulaLocal = mass(i - 1, j)
        Else
           Cells(i, j).Value = mass(i - 1, j)
        End If
     Next
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub