Перестановка с несколькими вариантами и различными весами

Итак, попробуйте следующее:

Sub Posibilities()
Dim sht As Worksheet, sht2 As Worksheet
Dim lRow As Long, Bound As Long
Dim Out As Variant, lOut As Variant, Values As Variant, Delimiter As Variant, Label As Variant

Set sht = Worksheets(1)
Set sht2 = Worksheets(2)

With sht
    lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
    Values = .Range("C1:C" & lRow + 1)
    Label = .Range("A1:B" & lRow)
End With

Values = OneDimension(Values)
Label = Labeling(Label)
Delimiter = SubArrays(Values)

Out = CalculateArrays(SliceArray(Values, 1, Delimiter(0) - 1), SliceArray(Values, Delimiter(0) + 1, Delimiter(1) - 1), 1)
lOut = CalculateArrays(SliceArray(Label, 1, Delimiter(0) - 1), SliceArray(Label, Delimiter(0) + 1, Delimiter(1) - 1), 2)

For i = 1 To UBound(Delimiter) - 1
    Out = CalculateArrays(Out, SliceArray(Values, Delimiter(i) + 1, Delimiter(i + 1) - 1), 1)
    lOut = CalculateArrays(lOut, SliceArray(Label, Delimiter(i) + 1, Delimiter(i + 1) - 1), 2)
Next i

'Output into Sheet(2)
For i = 1 To UBound(Out)
    sht2.Cells(i, 1).Value = Out(i)
    sht2.Cells(i, 2).Value = lOut(i)
Next i
sht2.Columns.AutoFit
End Sub

Function CalculateArrays(arr1 As Variant, arr2 As Variant, Mode As Integer) As Variant
'Input: 2 One-Dimensional Arrays, Mode(1 for Values, 2 for String to Add Delimiter)
'Adds Values of arr1 and arr2
'Output: One-Dimensional Array arr3 with all Combinations

Dim arr3() As Variant, Counter As Long: Counter = 1
Dim Elements1 As Long, Elements2 As Long

Elements1 = UBound(arr1) - LBound(arr1) + 1
Elements2 = UBound(arr2) - LBound(arr2) + 1

ReDim arr3(1 To Elements1 * Elements2)

For i = LBound(arr1) To UBound(arr1)
    For j = LBound(arr2) To UBound(arr2)
        Select Case Mode
        Case 1
            arr3(Counter) = arr1(i) + arr2(j)
        Case 2
            arr3(Counter) = arr1(i) & "|" & arr2(j)
        End Select
        Counter = Counter + 1
    Next j
Next i

CalculateArrays = arr3
End Function

Function SubArrays(arr1 As Variant) As Variant
'Input: One-Dimensional Array with empty Elements
'Searches for "" in arr1 (fields with no values in col c)
'Output: One-Dimensonal Array with Index of empty Fields

Dim arr2() As Variant, Count As Long: Count = 0

For i = 1 To UBound(arr1)
    If arr1(i) = "" Then
        ReDim Preserve arr2(Count)
        arr2(Count) = i
        Count = Count + 1
    End If
Next i

SubArrays = arr2
End Function

Function OneDimension(arr1 As Variant) As Variant
'Input: 2-Dimensional Array
'Transforms first Dimension of 2-Dimensional-Array into 1-Dimensional Array
'Output: 1-Dimensional Array

Dim arr2 As Variant

ReDim arr2(LBound(arr1, 1) To UBound(arr1, 1))

For i = LBound(arr1, 1) To UBound(arr1, 1)
    arr2(i) = arr1(i, 1)
Next i

OneDimension = arr2
End Function

Function SliceArray(arr1 As Variant, l As Integer, r As Integer) As Variant
'Input: 1-Dimensional Array, l as LeftBound, r As RightBound
'Output: 1-Dimensional Array from l to r

Dim arr2 As Variant

ReDim arr2(l To r)

For i = l To r
    arr2(i) = arr1(i)
Next i
SliceArray = arr2
End Function

Function Labeling(arr1 As Variant) As Variant
'Input: 2-Dimensional Array (Col A:B)
'Transforms Array into 1 -Dimension and adds Delimiter in between.
'Output: 1-Dimensional Array

Dim arr2 As Variant

ReDim arr2(1 To UBound(arr1, 1))

For i = 1 To UBound(arr1, 1)
    arr2(i) = arr1(i, 1) & ": " & arr1(i, 2)
Next i
Labeling = arr2
End Function

Входные данные:

Выход:

Я добавлю дальнейшее объяснение позже, пока я просто прокомментировал функции. Для его работы вам необходимо иметь ярлыки в Col A:B и данные в Col C первого рабочего листа. Важно разделять классы с пустым строкой, и данные начинаются в строке 1, а не 2, так что никаких надписей выше. Затем он выведет комбинации в рабочий лист 2 со значениями и комбинациями, как вы можете видеть на рисунках. Функция предназначена для работы с любыми значениями, если вы следуете требованиям ввода. Это также означает, что вы можете удалить и добавить категории.