Sub Собрать()
    
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr(), arrRes(), lr As Long, i As Long, j As Long, r As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = Worksheets("Лист1")
    Set shRes = Worksheets("Лист2")
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    shRes.Range("A1:A" & lr).ClearContents
    
    lr = shSrc.Columns("A:U").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr() = shSrc.Range("A1:U" & lr).Value
    ReDim arrRes(1 To UBound(arr) * 3, 1 To 1)
    
    For i = 1 To UBound(arr)
        If arr(i, 3) = "Марка" Then
            For j = 4 To 18 Step 7
                r = r + 1
                arrRes(r, 1) = arr(i, j)
            Next j
        End If
    Next i
    
    shRes.Range("A1").Resize(UBound(arrRes)).Value = arrRes()
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation
    
End Sub

Sub Собрать()

    Dim shRes As Worksheet, lr As Long
    
    Application.ScreenUpdating = False
    
    Set shRes = Worksheets("Лист2")
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    shRes.Range("A1:A" & lr).ClearContents
    
    'здесь укажите что искать на листе 1, в столбце "C" и в какой
    'столбец вставлять на листе 2
    Получить_данные "Марка", 1
    Получить_данные "Профиль", 2
    
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation
    
End Sub

Private Sub Получить_данные(strWhat As String, lngCol As Long)
    
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr(), arrRes(), lr As Long, i As Long, j As Long, r As Long
    
    Set shSrc = Worksheets("Лист1")
    Set shRes = Worksheets("Лист2")
    
    lr = shSrc.Columns("A:U").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr() = shSrc.Range("A1:U" & lr).Value
    ReDim arrRes(1 To UBound(arr) * 3, 1 To 1)
    
    For i = 1 To UBound(arr)
        If arr(i, 3) = strWhat Then
            For j = 4 To 18 Step 7
                r = r + 1
                arrRes(r, 1) = arr(i, j)
            Next j
        End If
    Next i
    
    shRes.Cells(1, lngCol).Resize(UBound(arrRes)).Value = arrRes()

End Sub

Option Explicit

Private arr() As Variant, bDebug As Boolean

Public Sub Бирко_Собиратель_aka_Страж_Матрицы()
    bDebug = 0
    Application.ScreenUpdating = IIf(bDebug, 1, 0)
    
    'на ws_dest проходит по первой строке
    'и формирует столбцы из значений ws_Sour
    ' http://www.excelworld.ru/forum/2-38118-1

    Dim ws_Sour As Worksheet, ws_dest As Worksheet
    Set ws_Sour = ActiveWorkbook.Worksheets("Лист1")
    Set ws_dest = ActiveWorkbook.Worksheets("Накопитель")

    Dim iCol_dest As Long, str As String
    With ws_dest
        For iCol_dest = 1 To .UsedRange.Columns.Count
            ReDim arr(0)

            Массив_Найденных ws_Sour, .Cells(1, iCol_dest).Value

            If UBound(arr) > 0 Then _
               .Cells(2, iCol_dest).Resize(UBound(arr), 1) = _
                Application.WorksheetFunction.Transpose(arr)
        Next
    End With
End Sub

Private Sub Массив_Найденных(ws As Worksheet, str As String)
    'нахожу все вхождения str
    Dim rng As Range, firstAddress As String

    With ws.Cells
        Set rng = .Find(str, LookIn:=xlValues)
        If Not rng Is Nothing Then
            
            If bDebug Then ws.Activate: rng.Select
            
            firstAddress = rng.Address
            arr(UBound(arr)) = Первый_Кто_Встретился(rng)
            Do
                Set rng = .FindNext(rng)
                
                ReDim Preserve arr(UBound(arr) + 1)
                
                If rng Is Nothing Then Exit Do    '=>
                
                If bDebug Then ws.Activate: rng.Select
                
                arr(UBound(arr)) = Первый_Кто_Встретился(rng)
            
            Loop While rng.Address <> firstAddress
        End If
    End With
End Sub

Private Function Первый_Кто_Встретился(rng As Range) As Variant
    'ищет вправо по строке первую непустую ячейку
    Dim iCol As Long

    With rng.Parent
        For iCol = rng.Column + 1 To .Columns.Count

            If .Cells(rng.Row, iCol).Value <> vbNullString Then
                
                If bDebug Then .Activate: .Cells(rng.Row, iCol).Select

                Первый_Кто_Встретился = .Cells(rng.Row, iCol).Value
                Exit For    ' =>
            End If
        Next
    End With
End Function