| |
みんさん、おはようございます。
同じような質問に過去にも投稿したことが何回かあります。
今までは、組合せリストが気の遠くなる数字でもVBAが絶え得うるコード
（例え2＾30-1=1073741823で時間がかかってもメモリ不足を起こさない
且つ、再利用しやすいインターフェース）
がこの手のご質問では私の目的でした。
（足し算の組合せを速く求める問題には、あまり興味がなかったのですが）
以前にも投稿したコードに少しコードを追加して
2＾30-1通りのチェックの中でどれだけのリスト数のチェックを飛ばせるかで考えました。
標準モジュールに
'===============================================================
Sub main()
Dim 組合せセル範囲 As Range
Dim 抜き取り数 As Long
Dim asum As Double
Dim 合計 As Long
Dim d_rw As Long
合計 = 74 '求めたい合計値を指定
d_rw = 1
Set 組合せセル範囲 = Range("a1", Cells(Rows.Count, "a").End(xlUp))
組合せセル範囲.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
For 抜き取り数 = 1 To 組合せセル範囲.Count
Call init_comb(組合せセル範囲, 抜き取り数)
ReDim ans(1 To 抜き取り数)
Do While get_comb(ans()) = 0
asum = Application.Sum(ans())
If asum = 合計 Then
Range(Cells(d_rw, 3), Cells(d_rw, 抜き取り数 + 2)).Value = ans()
d_rw = d_rw + 1
ElseIf asum > 合計 Then
Call skip_comb
End If
Loop
Next
MsgBox "以上、" & d_rw - 1 & " 通り検出しました"
End Sub
別の標準モジュールに
'=======================================
Option Explicit
Private c_svn As Long '抜き取り数保存
Private c_myarray() '組合せ対象値の配列
Private c_idx() As Long '配列のカレントポインタ
Private cs_x() As Long '配列の基盤ポインタ
'=======================================
Function init_comb(rng As Range, seln As Long) As Double
Dim i As Long
Dim crng As Range
c_svn = seln
Erase c_myarray()
Erase c_idx()
Erase cs_x()
i = 1
ReDim Preserve c_myarray(1 To rng.Count)
For Each crng In rng
c_myarray(i) = crng.Value
i = i + 1
Next
ReDim cs_x(1 To seln)
ReDim c_idx(1 To seln)
For i = 1 To UBound(c_idx())
cs_x(i) = i
c_idx(i) = i
Next
c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1
init_comb = WorksheetFunction.Combin(rng.Count, seln)
End Function
'=======================================
Function get_comb(ans()) As Long
Dim i As Long
Dim j As Long
get_comb = 1
For i = UBound(c_idx()) To LBound(c_idx()) Step -1
If c_idx(i) + 1 <= UBound(c_myarray()) - c_svn + i Then
c_idx(i) = c_idx(i) + 1
get_comb = 0
Exit For
Else
c_idx(i) = cs_x(i) + 1
cs_x(i) = cs_x(i) + 1
For j = i + 1 To UBound(cs_x())
cs_x(j) = cs_x(j - 1) + 1
c_idx(j) = cs_x(j)
Next j
End If
Next
If get_comb = 0 Then
For i = LBound(c_idx()) To UBound(c_idx())
ans(i) = c_myarray(c_idx(i))
Next
End If
End Function
'=======================================
Function skip_comb()
Dim i As Long
For i = UBound(c_idx()) To LBound(c_idx()) + 1 Step -1
If c_idx(i) <> c_idx(i - 1) + 1 Then
c_idx(i) = UBound(c_myarray()) - c_svn + i
Exit For
End If
c_idx(i) = UBound(c_myarray()) - c_svn + i
Next
End Function
'=======================================
Sub close_comb()
Erase c_myarray()
Erase c_idx()
Erase cs_x()
End Sub
アクティブシートのセルＡ1からＡ２、Ａ３・・・Ａ３０に例えば、
196
182
179
178
177
167
142
140
139
130
129
125
114
111
102
90
79
76
63
62
60
48
46
30
17
15
11
9
6
5
というデータがある場合、
mainを実行してみてください。
上記のコードでは、合計値が74になる数の組合せを同じシートの
セルＣ１から書き込みます。
（全てのリストを出力しますから、一つでよいならmainを変更してください）
セルに書き込んでいますからリストが65536を超えればエラーになりますが、
その時は出力場所を変えてください。
まっ、上記の例では、一瞬ですし、９通りの組合せがでています。
それでも全部のリストをチェックしなければならない事象の場合は時間がかかりますが・・。
試してみてください。
|
|
ichinose
- 06/9/13(水) 6:37 -
