| |
▼ヒロヒロ さん：
こんばんは。
似たようなご質問が過去にもありましたが・・・。
この問題、組み合わせリストを作成するコードがあれば、９割方 完成ですよね？
>1200
>1300
>1400
>1600
>1000
仮にアクティブシートの
Ａ１〜Ｅ１にそれぞれ 1200、1300,1400,1600,1000
と 入力されているとします。
標準モジュールに
'==================================================
Sub main()
Dim 組合せセル範囲 As Range
Dim 抜き取り数 As Long
Dim 合計 As Long
Dim d_rw As Long
合計 = 3700
d_rw = 2
Set 組合せセル範囲 = Range("a1:e1")
For 抜き取り数 = 1 To 組合せセル範囲.Count
Call comb_init(組合せセル範囲, 抜き取り数, 1)
ReDim ans(1 To 抜き取り数)
Do While get_comb(ans()) = 0
If Evaluate(Join(ans(), "+")) = 合計 Then
Range(Cells(d_rw, 1), Cells(d_rw, 抜き取り数)).Value = ans()
d_rw = d_rw + 1
End If
Loop
Next
MsgBox "以上、" & d_rw - 2 & " 通り検出しました"
End Sub
別の標準モジュールに以前に作ったコードです。
'=========================================================
Private c_svn As Long
Private c_myarray()
Private c_idx() As Long
Private cs_x() As Long
'======================================================================
Function comb_init(rng As Range, seln As Long, Optional val_typ As Long = 1) As Double
'組合せ処理の初期化
'input : rng : 組合せを行うセル範囲
' seln: 抜き取り数
' val_type: セル範囲rngのどのプロパティを組み合わせ対象とするかのフラグ
' 1 - value 2- address 3-text
'outptu: comb_init --- 組合せ数
c_svn = seln
Erase c_myarray
Erase c_idx
Erase cs_x()
i = 1
For Each crng In rng
ReDim Preserve c_myarray(1 To i)
c_myarray(i) = Choose(val_typ, crng.Value, crng.Address, crng.Text)
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
comb_init = WorksheetFunction.Combin(rng.Count, seln)
End Function
'===================================================================
Function get_comb(ans()) As Long
'組合せメンバを配列に取得する
'output : ans() : 組合せメンバー（引数は、1から始まる）
' get_comb : 0-正常に取得 1-データの終わり
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
これで当該シートをアクティブにした状態で
mainを実行してみてください。
合計値が一致するメンバーを
セルＡ２から表示します。
|
|
ichinose
- 05/10/20(木) 19:14 -
