多个选项和不同权重的置换

Question

我正试图建立一个风险计算矩阵。因此，当风险被识别时，这种风险对于每种类型都有一个类别。有7种不同的类型和20个不同的类，如图所示：

每个班级都有不同的重量。

因此，例如，名为riskA的风险定义为：

1. 策略性
2. biggerThan20
3. 业务
4. 是
5. 是
6. 是
7. 是

然后，这些组合的重量= (10 + 30 + 20 + 70 + 40 + 60 + 50)重量= 280。

我需要知道所有可能的计算组合。我相信960个组合。我试图运行一些javaScript代码来获得结果，但没有成功。我也想不出用excel做这件事的简单方法。

具有可能值的电子表格图像：

​

​

Answer 1

所以试试这个：

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中的数据。使用空行分隔类非常重要，数据以Row 1 (而不是2 )开始，因此上面没有标签。然后，它会将这些组合输出到工作表2中，其中包含您可以在图片中看到的值和组合。如果您遵循输入要求，该函数将被布局为与任何值一起工作。这也意味着您可以删除和添加类别。