VBA100本ノック 魔球編1 組み合わせ問題

mod_VBA100_MagicBall001.bas

Option Explicit

Rem 魔球編1 組み合わせ問題
Sub MagicBall001()
    Dim srcArr: srcArr = CreateRandArray(5, 20, 40)
    Dim retArr
    retArr = func(srcArr, 100)
    If IsEmpty(retArr) Then MsgBox Join(srcArr, ",") & "で100を超える組み合わせはありません": Exit Sub
    Debug.Print Join(srcArr, ",") & " - " & Join(retArr, " + ") & " = " & Sum(retArr)
End Sub

Rem 指定した要素数の乱数配列を作成する
Rem  @param nCnt    生成する乱数の個数
Rem  @param nMin    乱数の最小値
Rem  @param nMax    乱数の最大値
Rem  @return        乱数の配列
Function CreateRandArray(nCnt As Long, nMin As Long, nMax As Long) As Variant
    If nCnt = 0 Then Stop
    Randomize
    
    Dim arr
    ReDim arr(1 To nCnt)
    
    Dim i As Long
    For i = 1 To nCnt
        arr(i) = Int(Rnd() * (nMax - nMin + 1)) + nMin
    Next
    
    CreateRandArray = arr
End Function

Rem
Rem @param arr 20～40の整数の配列
Rem @return 100を超える100に最も近い組み合わせを見つけ配列
Rem
Function func(arr, LowerNum As Long) As Variant  'Array
    ReDim Preserve arr(1 To UBound(arr) + (1 - LBound(arr)))
    
    Dim cll As New Collection
    If UBound(arr) >= 2 Then Call PairAdd(arr, cll)
    If UBound(arr) >= 3 Then Call TrioAdd(arr, cll)
    If UBound(arr) >= 4 Then Call QuarAdd(arr, cll)
    If UBound(arr) >= 5 Then Call QuinAdd(arr, cll)
    
    Dim kai As Long: kai = 999999
    Dim ret As Variant
    
    Dim itm
    For Each itm In cll
        If LowerNum < Sum(itm) Then
            If kai > Sum(itm) Then
                kai = Sum(itm)
'                Debug.Print kai
                ret = itm
            End If
        End If
    Next
    
    func = ret
End Function

Rem 配列の全アイテムの合計
Function Sum(srcArr) As Long
    Sum = 0
    Dim itm
    For Each itm In srcArr
        Sum = Sum + itm
    Next
End Function

Rem 2つの組み合わせを返す
Function PairAdd(arr, destCll)
    Dim i As Long, j As Long
    For i = 1 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            destCll.Add Array(arr(i), arr(j))
        Next
    Next
End Function

Rem 3つの組み合わせを返す
Function TrioAdd(arr, destCll)
    Dim i As Long, j As Long, k As Long
    For i = 1 To UBound(arr) - 2
        For j = i + 1 To UBound(arr) - 1
            For k = j + 1 To UBound(arr)
                destCll.Add Array(arr(i), arr(j), arr(k))
'                Debug.Print i, j, k
            Next
        Next
    Next
End Function

Rem 4つの組み合わせを返す
Function QuarAdd(arr, destCll)
    Dim i As Long, j As Long, k As Long, l As Long
    For i = 1 To UBound(arr) - 3
        For j = i + 1 To UBound(arr) - 2
            For k = j + 1 To UBound(arr) - 1
                For l = k + 1 To UBound(arr)
                    destCll.Add Array(arr(i), arr(j), arr(k), arr(l))
'                    Debug.Print i, j, k, l
                Next
            Next
        Next
    Next
End Function

Rem 5つの組み合わせを返す
Function QuinAdd(arr, destCll)
    Dim i As Long, j As Long, k As Long, l As Long, m As Long
    For i = 1 To UBound(arr) - 4
        For j = i + 1 To UBound(arr) - 3
            For k = j + 1 To UBound(arr) - 2
                For l = k + 1 To UBound(arr) - 1
                    For m = l + 1 To UBound(arr)
                        destCll.Add Array(arr(i), arr(j), arr(k), arr(l), arr(m))
'                        Debug.Print i, j, k, l, m
                    Next
                Next
            Next
        Next
    Next
End Function

#VBA100本ノック の 魔球編1 組み合わせ問題の解答例です。

出題ツイート
https://twitter.com/yamaoka_ss/status/1334047954382901249

解説記事
https://excel-ubara.com/vba100/VBA100_M001.html

ライブコーディング動画
https://youtu.be/hCGWz-WbkFw