Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


65901 / 76738 ←次へ | 前へ→

【15405】Re:残りのない組み合わせ
回答  ichinose  - 04/6/23(水) 19:21 -

引用なし
パスワード
   くんくん さん、ちゃっぴさん、こんばんは。
>説明の付け足しです。
>日々、大幅に沢山の小幅を残幅が最小になる組み合わせを
>考えています。
>
>小幅は、前にも書いたとおりに、5刻みです。
>500という大幅があれば、
>小幅は、ランダムにあって、
>305
>305
>125
>300
>50
>430
>430
>といった具合です。
>その与えられた小幅の中のみで、組み合わせを考え、
>残幅の少ないものから順に表示させたいです。
>データ量は、すごく多いという量ではありません。
>
>結果は、こんな感じにしたいです。
>430 50  (残20)
>305 125  (残70)
>430    (残70)
>305    (残195)
>300    (残200)
>これで、すべての小幅が組み合わされています。
まず、仕様です。
上の例題に値を固定してコードを書きました。
コードを見ていただければ、変更は可能かと思います。

アクティブシートのセルA1〜A7に小幅メンバーの数値が入力して下さい。
   A
1  305
2  305
3  125
4  300
5  50
6  430
7  430

この数値を入力して(値は変えてもかまいません)下記に記述してあるmainを実行して下さい。

C列 3行目からリストが表示され、F列には、差幅値(残幅)が表示されます。

では、コードです。
標準モジュール(Module1)に、
'====================================================================
Sub main()
  Const 抜き取り = 2
  Dim rng As Range
  Dim 最小差幅リスト
  Dim r_cnt As Long
  Dim dsprow As Long
  Dim nrng As Range
  Dim 組み合わせ数 As Long
  組み合わせ数 = 抜き取り
  dsprow = 3
  Set rng = Range("a1:a7") '小幅メンバセル範囲のセット
  Do While Not rng Is Nothing
   If rng.Count >= 抜き取り Then
    組み合わせ数 = 抜き取り
   Else
    組み合わせ数 = rng.Count
    End If
   If get_min_comb(rng, 最小差幅リスト, 組み合わせ数, 500) = 0 Then
'                              ↑大幅の値を変更するならこの500を変更

    wk = UBound(最小差幅リスト) - LBound(最小差幅リスト)
    Range(Cells(dsprow, 3), Cells(dsprow, 3 + wk)).Value = 最小差幅リスト
    Cells(dsprow, 6).Value = Evaluate("500-(" & Join(最小差幅リスト, "+") & ")")
    dsprow = dsprow + 1
    End If
   Set rng = get_next_rng(rng, 最小差幅リスト)
'        ↑表示したセル以外の範囲を設定
   Loop
End Sub
'======================================================================
Function get_next_rng(rng, dellist) As Range
'指定されたセル範囲から、dellistに該当しないセルをひとつ削除する
  ReDim rrng(1 To (UBound(dellist) - LBound(dellist) + 1)) As Range
  For idx = LBound(dellist) To UBound(dellist)
   Set rrng(idx) = Nothing
   f_flg = 0
   For Each crng In rng
     If f_flg = 0 And crng.Value = dellist(idx) Then
      f_flg = 1
     Else
      If Not rrng(idx) Is Nothing Then
        Set rrng(idx) = Union(rrng(idx), crng)
      Else
        Set rrng(idx) = crng
        End If
      End If
     Next
   Next
  Set get_next_rng = Nothing
  For idx = LBound(rrng()) To UBound(rrng())
   If Not rrng(idx) Is Nothing Then
     If Not get_next_rng Is Nothing Then
      Set get_next_rng = Application.Intersect(get_next_rng, rrng(idx))
     Else
      Set get_next_rng = rrng(idx)
      End If
     End If
   Next idx
End Function
'=========================================================================
Function get_min_comb(rng As Range, myarray As Variant, 最大抜き取り数 As Long, 大幅 As Long) As Long
'指定されたセル範囲の組み合わせから大幅との差幅の小さい組み合わせを取得する
  Dim idx As Long
  Dim comb_list()
  Dim ans()
  Dim 差幅 As Long
  get_max_comb = 1
  差幅 = 大幅
  For idx = 最大抜き取り数 To 1 Step -1
   ReDim comb_list(1 To idx)
   Call comb_init(rng, idx)
   Do While get_comb(comb_list()) = 0
     wk = Evaluate(大幅 & "-(" & Join(comb_list(), "+") & ")")
     If Evaluate(大幅 & "-(" & Join(comb_list(), "+") & ")") >= 0 Then
      If 差幅 > wk Then
        差幅 = wk
        Erase ans()
        ans() = comb_list()
        get_min_comb = 0
        End If
      End If
     Loop
   Next
  If get_min_comb = 0 Then
   myarray = ans()
   End If
End Function


他の標準モジュール(Module2)に
'=======================================================================
  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) As Double
'組み合わせ情報の初期化
  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) = 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
  comb_init = WorksheetFunction.Combin(rng.Count, seln)
End Function
'======================================================================
Function get_comb(ans()) 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


以上です。
くんくん さんが都合の良いような変更は、mainプロシジャーの入力データの箇所の
変更でよいと思いますが・・・。
確認してみて下さい。

それから、次回からは、こういうアルゴリズムに関するようなご質問は
もう少し詳しく(例えば、例も最低3例ぐらい)記述して下さいね!!
0 hits

【15381】残りのない組み合わせ さき 04/6/22(火) 22:45 質問
【15382】Re:残りのない組み合わせ ちゃっぴ 04/6/22(火) 23:12 発言
【15383】Re:残りのない組み合わせ ichinose 04/6/23(水) 0:04 発言
【15385】Re:残りのない組み合わせ くんくん 04/6/23(水) 7:56 質問
【15387】Re:残りのない組み合わせ くんくん 04/6/23(水) 8:47 質問
【15390】Re:残りのない組み合わせ ちゃっぴ 04/6/23(水) 10:56 発言
【15392】Re:残りのない組み合わせ くんくん 04/6/23(水) 11:41 質問
【15403】Re:残りのない組み合わせ ちゃっぴ 04/6/23(水) 16:41 発言
【15405】Re:残りのない組み合わせ ichinose 04/6/23(水) 19:21 回答
【15406】Re:残りのない組み合わせ 訂正と追伸 ichinose 04/6/23(水) 19:35 発言
【15410】ありがとうございます。 くんくん 04/6/24(木) 9:12 お礼

65901 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free