Sub qq()
     Dim arr, arr1, arr2
     Dim i&, j&, k&, sCol&
     arr = Sheets("Ключевые слова").Range("A1").CurrentRegion.Value
     ReDim Preserve arr(1 To UBound(arr), 1 To 3)

     With Sheets("Данные")
         arr1 = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value
     End With
     For i = j + 1 To UBound(arr)
         If j = 0 Then j = j + 1
         For j = j To UBound(arr1)
             If arr1(j, 1) = arr(i, 1) Then
                 arr(i, 2) = j
                 If i > 1 Then arr(i - 1, 3) = j
                 Exit For
             End If
         Next
     Next
     arr(i - 1, 3) = UBound(arr1) + 1
     With Sheets("Структура")

         On Error Resume Next
         For i = 1 To UBound(arr)
             ReDim arr2(1 To arr(i, 3) - arr(i, 2) + 1, 1 To 1)
             k = 1
             For j = arr(i, 2) + 1 To arr(i, 3)
                 If Len(arr1(j, 1)) Then
                     arr2(k, 1) = arr1(j, 1)
                     k = k + 1
                 End If
             Next
             sCol = .Rows(1).Find(What:=arr(i, 1), LookAt:=xlWhole).Column
             .Cells(.Rows.Count, sCol).End(xlUp).Offset(1).Resize(UBound(arr2) - 1) = arr2
         Next
     End With

End Sub

Sub qq()
     Dim arr, arr1, arr2
     Dim i&, j&, k&, sCol&, kk&
     arr = Sheets("Ключевые слова").Range("A1").CurrentRegion.Value
     ReDim Preserve arr(1 To UBound(arr), 1 To 3)

     With Sheets("Данные")
         sCol = .Cells.Find("*", , , , 2, xlPrevious).Column
         arr1 = .Range(.Cells(1, sCol), .Cells(.Rows.Count, "A").End(xlUp)).Value
     End With
     For i = j + 1 To UBound(arr)
         If j = 0 Then j = j + 1
         For j = j To UBound(arr1)
             If arr1(j, 1) = arr(i, 1) Then
                 arr(i, 2) = j
                 If i > 1 Then arr(i - 1, 3) = j
                 Exit For
             End If
         Next
     Next
     arr(i - 1, 3) = UBound(arr1) + 1
     With Sheets("Структура")

         On Error Resume Next
         For i = 1 To UBound(arr)
             ReDim arr2(1 To arr(i, 3) - arr(i, 2) + 1, 1 To UBound(arr1, 2))
             k = 1
             For j = arr(i, 2) + 1 To arr(i, 3)
                 For kk = 1 To UBound(arr1, 2)
                     arr2(k, kk) = arr1(j, kk)
                 Next
                     k = k + 1
             Next
             sCol = .Rows(1).Find(What:=arr(i, 1), LookAt:=xlWhole).Column
             .Cells(.Rows.Count, sCol).End(xlUp).Offset(1).Resize(UBound(arr2) - 2, UBound(arr2, 2)) = arr2
         Next
     End With

End Sub

Sub Rio_Awesome_Data_Eliciter()

'Author:    Roman Rioran Voronov
'Date:      the 2-nd of October, 2014
'Feedback:  voronov_rv@mail.ru

Dim A As Long 'To roll Data rows
Dim AA As Long 'Data all rows
Dim B As Long 'To roll key words rows
Dim BB As Long 'Key words all rows
Dim C As Long 'To roll Structure columns
Dim StartX As Long 'From where to search

Dim rngX As Range
Dim rngY As Range

Dim DataS As Worksheet
Dim WordS As Worksheet
Dim ProdS As Worksheet

Set DataS = ThisWorkbook.Worksheets("Данные")
Set WordS = ThisWorkbook.Worksheets("Ключевые слова")
Set ProdS = ThisWorkbook.Worksheets("Структура")

C = 1: StartX = 1
Application.ScreenUpdating = False

With DataS
      AA = .Cells(.Rows.Count, 1).End(xlUp).Row
      If AA < 2 Then Exit Sub
End With

With WordS
      BB = .Cells(.Rows.Count, 1).End(xlUp).Row
      If BB < 2 Then Exit Sub
End With

For B = 1 To BB
      Set rngX = DataS.Range("A" & StartX & ":A" & AA).Find(WordS.Cells(B, 1).Value, , , xlWhole)
      If Not rngX Is Nothing Then
          If B = BB Then
              ProdS.Cells(1, C).Value = WordS.Cells(B, 1).Value
              ProdS.Cells(2, C).Resize(AA - rngX.Row, 5).Value = rngX.Offset(1, 0).Resize(AA - rngX.Row, 5).Value
              Exit Sub
          End If
          For A = B + 1 To BB
              Set rngY = DataS.Range("A" & StartX & ":A" & AA).Find(WordS.Cells(A, 1).Value, , , xlWhole)
              If Not rngY Is Nothing Then
                  ProdS.Cells(1, C).Value = WordS.Cells(B, 1).Value
                  ProdS.Cells(2, C).Resize(rngY.Row - rngX.Row - 1, 5).Value = rngX.Offset(1, 0).Resize(rngY.Row - rngX.Row - 1, 5).Value
                  C = C + 5: B = A - 1: StartX = rngY.Row - 1
                  Exit For
              ElseIf A = BB Then
                  ProdS.Cells(1, C).Value = WordS.Cells(B, 1).Value
                  ProdS.Cells(2, C).Resize(AA - rngX.Row, 5).Value = rngX.Offset(1, 0).Resize(AA - rngX.Row, 5).Value
                  Exit Sub
              End If
          Next A
      End If
Next B

Application.ScreenUpdating = True

End Sub