Sub А_Основа()
Dim LastRow1 As Long
Dim osnova() As Variant
Dim Riz() As Variant
Dim str1 As String
Dim i As Integer, j As Integer, k As Integer
Dim t As Variant
Dim kab As Variant

' Вычисляем количество заполненных строк
LastRow1 = Cells(Rows.Count, 2).End(xlUp).Row
' Заполняем массив osnova
ReDim osnova(1 To LastRow1, 1 To 7)
For i = 4 To LastRow1
     For j = 1 To 7
         osnova(i, j) = Cells(i, j)
     Next j
Next i
' Создаём массив Riz и заполняем
ReDim Riz(1 To LastRow1, 1 To 15)
k = 1
For i = 4 To LastRow1
     For j = 1 To 4
         If IsEmpty(osnova(i, 1)) Then
             Riz(i, 1) = osnova(i, 2)
           Else
             Riz(i, 1) = k
             Riz(i, 2) = osnova(i, 2)
             Riz(i, 3) = osnova(i, 6)
             t = osnova(i, 6)
             kab = Split(t, "х", 2)
             Riz(i, 4) = kab(1)
         End If
     Next j
   If IsEmpty(osnova(i, 1)) Then
    Else
     k = k + 1
   End If
Next i
' Вывод на экран массива Riz
  For i = 4 To LastRow1
     For j = 1 To 4
       str1 = str1 & Riz(i, j) & ","
     Next j
    str1 = str1 & Chr(13)
  Next i
  MsgBox "Массив Riz:" & Chr(13) & str1
End Sub