Sub jjj()
Dim arr()
Const sob = 15, ish = 3
ReDim arr(sob - 1, ish - 1)
End Sub

Sub jjj()
Dim arr(), arr_sob(), arr_ish()
    arr() = Range("B4:AB6")
    arr_sob() = Range("A4:A6")
    arr_ish() = Range("B3:AB3")
    For r = 1 To UBound(arr, 1)
        For c = 1 To UBound(arr, 2)
            Debug.Print arr(r, c), arr_sob(r, 1), arr_ish(1, c)
        Next c
    Next r
End Sub

Sub jjj()
Dim arr(), arr_sob(), arr_ish()
    arr() = Range("B4:AB6")
    arr_sob() = Range("A9:A11")
    arr_ish() = Range("B8:D8")
    r_n = UBound(arr, 1)
    c_n = UBound(arr, 2)
    For r = 1 To r_n
        For c = 1 To c_n
            i_sum = (r - 1) * c_n + c
            arr(r, c) = arr_ish(1, ((i_sum - 1) Mod 3) + 1)
        Next c
    Next r
    Range("B4:AB6") = arr
End Sub

Sub usl4()
k = 3 'негатив-нейтрал-позитив
Dim arr()
Dim a()
ReDim a(1 To k)
a(1) = "negative"
a(2) = "neutral"
a(3) = "positive"
us = Val(InputBox("сколько вариантов?"))
ReDim arr(1 To us, 1 To k ^ us + 1)
'x = 4 + 3
q = 1

For y = 1 To us
For i = 2 To k ^ us + 1

arr(y, 1) = "усл" & y

For j = i To i + k ^ (us - y) - 1
arr(y, j) = a(q)
Next
If q = 3 Then q = 1 Else q = q + 1
i = i + k ^ (us - y) - 1
Next
Next
v = MsgBox("массив вариантов сформирован. Выгрузить на лист?", vbYesNo)

Select Case v
    Case vbNo: Exit Sub
    Case vbYes
    If k ^ us > Columns.Count Then MsgBox "недостаточно места": Exit Sub
    For l = 1 To us
    For x = 1 To k ^ us + 1
        Cells(l, x).Value = arr(l, x)
    Next
    Next
End Select

End Sub