- ベストアンサー
エクセルマクロの高速化をしたい
合計の数字を指定し、リストからどの数字の組み合わせか抽出する マクロを作成中です。 ↓の質問を参考にしています。 http://oshiete1.goo.ne.jp/qa1229646.html やり方はすごく参考になるのですが、処理速度が遅く、実用的には だいたい30個の数字リスト程度が限度です。 100個の数字リストから組み合わせを抽出できるように マクロの高速化ははかれないものでしょうか?
- みんなの回答 (10)
- 専門家の回答
質問者が選んだベストアンサー
#4~9です。レスが遅くなってすみません。 補足にあるご理解でばっちりあってますので 既に自己解決されたかもしれませんが…。 long型の最大値は2,147,483,647ですから、 「元リストの、使用/非使用指定をかけていない部分の総和」が 20億を超えるような場合にはsumAry()があふれてしまいますね。 おっしゃるように、sumAry()の型を Currency型等に変えれば動作するハズです。 sumAry()だけでなく、 ・itmAry() : モジュールレベル変数 ・sumOpt : 親Pの変数 ・spcSum : 親Pの変数 ・tmpSum : 子Pの引数 も「金額(?)」が入りますから、直した方が安全かもしれません。 (sumOptは、反転処理の際に元の値よりも大きくなることがあります) 以上ご参考まで。
その他の回答 (9)
- _Kyle
- ベストアンサー率78% (109/139)
#4~#8です。 -------------------------------------------- ■1.コメントを数字の隣に表記したときに、検索結果として一緒に出力 >結果を見たときに何の金額なのかわかっていいな~ ん~、#8の「元リストと同位置に書出し」オプションは そういう趣旨でつけてみたんですが…。 「結果を2列セットで吐く」というのは、技術的には難しくはありませんが、 「取り回しが悪い」というか「データとして汚い」感じがするので 趣味とか美意識(笑)の問題として、私としては対応しかねます^^;; とりあえず、C列を「コメント」列に使うものとして、 列使用設定をずらし、B7セルで「表示値形式」を選べるようにしました。 ・0または空白 : 使用する要素の数値を表示 ・1 : 使用する要素のコメントを表示 ・2 : 数値とコメントを単一の文字列として表示 ・3 : "●"を表示(「書出形式」を「元リストと同位置」にする前提) なお、要望4・5に対応する関係もあって「書出形式」オプションを ・0または空白 : 上詰 ・1 : 元リストと同位置 に変更しました。 -------------------------------------------- ■2.処理途中で「ESC」で、抜けたときも、そこまでの結果を表示できないか。 ESCキーで中断した際にそれまでの結果を表示するようにしました。 ※ESCを押した時点で確認を求めず直ちに中止します(続行不可) -------------------------------------------- ■3.組み合わせ個数の少ないものから順番に表記できないか。 まず「個数の少ないものから順に探索する」のは【原理的に困難】です。 次に「個数の少ないものから順に出力する」のは【仕様上困難】です。 ※全ての結果を得る(全件探索する)ことが前提なら、 最後に個数を調べて(列方向に)ソートすれば済む話ですが、 全ての結果を得ていない(探索を途中で打ち切った)場合は、 探索しなかった部分について個数を知ることができません。 というわけで、 「個数を指定した探索を、繰り返し(連続して)行う」 という方式にしました。 B4セルが 0または空白 : 一括探索 1 : 個数の少ない順に連続探索 2 : 個数の多い順に連続探索 -------------------------------------------- ■4.リストにある金額をあらかじめ指定できないか ■5.検索に使うB列のリスト範囲を指定 「どのように指定するか」いろいろ方法はありますが、 とりあえず、E列を「指定列」として、 ・E列が"○"の要素 : 必ず使用する ・E列が"×"の要素 : 使用しない という仕様にしました。 要素「2」の行のE列を"○"とすれば、「2」を含む組を探索します。 11行目以降のE列を"×"とすれば、1行目~10行目の要素のみを使う組を探索します。 なお、上限・下限設定は「必ず使用する」要素の個数を含めて設定してください。 ------------------------------------------------------------------- 仕様まとめ ・A列:設定項目見出列 ・B列:設定項目入力列 ・C列:リスト見出(コメント)入力列 ・D列:リスト入力列 ・E列:使用/不使用要素指定列 ・F列以降:結果表示列 ・B1 : 合計 ・B2 : 使用個数の上限 ・B3 : 使用個数の下限 ・B4 : 使用個数の最少/最多から連続探索(0/1/2) ・B5 : 探索件数の上限 ・B6 : 書出形式(0/1) ・B7 : 表示値形式(0/1/2/3) '----------------------↓ ココカラ ↓---------------------- Private Const optCln As Long = 2 'B列:設定列の列番号 Private Const cmtCln As Long = 3 'C列:コメント列の列番号 Private Const itmCln As Long = 4 'D列:リスト列の列番号 Private Const spcCln As Long = 5 'E列:使用指定列の列番号 Private Const rtnCln As Long = 6 'F列:結果表示範囲最左列の列番号 Private itmCnt As Long '候補リスト個数 Private itmAry() As Long '候補リスト配列 Private rtnCnt As Long '結果個数 Private rtnAry() As Boolean '結果配列 Private sumAry() As Long '後方和配列 Private tmpAry() As Boolean '経過配列 Private rtnLmt As Long '探索件数上限 '------------↓↑ ツヅク ↑↓------------ Sub Sample() Dim i As Long, j As Long, k As Long Dim t As Variant 'タイムカウンタ Dim orgCnt As Long '元リスト個数 Dim orgAry() As Variant '表示値配列 Dim sumOpt As Long '初期合計 Dim uprOpt As Long '上限設定 Dim lwrOpt As Long '下限設定 Dim seqOpt As Long '連続探索設定 Dim rtnOpt As Long '探索件数設定 Dim dspOpt As Long '書出形式設定 Dim valOpt As Long '表示値形式設定 Dim spcCnt As Long '必須要素個数 Dim spcSum As Long '必須要素合計 Dim cntMax As Long '最多個数 Dim cntMin As Long '最少個数 Dim tmpSwp As Long '入替退避用 Dim dspAry As Variant '書出データ Dim dspLmt As Long '書出件数上限 Dim rvsFlg As Boolean '反転フラグ t = Timer Range(Columns(rtnCln), Columns(Columns.Count)).Clear '設定取得 sumOpt = Cells(1, optCln).Value uprOpt = Cells(2, optCln).Value lwrOpt = Cells(3, optCln).Value seqOpt = Cells(4, optCln).Value rtnOpt = Cells(5, optCln).Value dspOpt = Cells(6, optCln).Value valOpt = Cells(7, optCln).Value Application.ScreenUpdating = False orgCnt = Cells(Rows.Count, itmCln).End(xlUp).Row Erase orgAry ReDim orgAry(1 To orgCnt, 0 To 1) For i = 1 To orgCnt '表示値 Select Case valOpt Case 0 orgAry(i, 0) = Cells(i, itmCln).Value Case 1 orgAry(i, 0) = Cells(i, cmtCln).Value Case 2 orgAry(i, 0) = _ String(Len(Str(sumOpt)) - _ Len(Str(Cells(i, itmCln).Value)), " ") & _ Cells(i, itmCln).Value & ":" & Cells(i, cmtCln).Value Case 3 orgAry(i, 0) = "●" End Select '作業列書出 Select Case Cells(i, spcCln).Value Case "○" orgAry(i, 1) = True spcCnt = spcCnt + 1 spcSum = spcSum + Cells(i, itmCln).Value Case "×" '無視 Case Else Cells(i, rtnCln + 0).Value = Cells(i, itmCln).Value Cells(i, rtnCln + 1).Value = i End Select Next i Columns(rtnCln).Resize(, 2).Sort _ Key1:=Cells(1, rtnCln), Order1:=xlAscending, Header:=xlNo itmCnt = Cells(Rows.Count, rtnCln).End(xlUp).Row Erase sumAry ReDim itmAry(0 To itmCnt, 0 To 1) ReDim tmpAry(1 To itmCnt) ReDim sumAry(1 To itmCnt + 1) '候補リスト配列取得 For i = 1 To itmCnt itmAry(i, 0) = Cells(i, rtnCln + 0).Value itmAry(i, 1) = Cells(i, rtnCln + 1).Value Next i Columns(rtnCln).Resize(, 2).Delete Application.ScreenUpdating = True '設定値調整 With Application.WorksheetFunction sumOpt = sumOpt - spcSum uprOpt = uprOpt - spcCnt lwrOpt = lwrOpt - spcCnt End With If (uprOpt <= 0) Or (itmCnt < uprOpt) Then uprOpt = itmCnt If (lwrOpt <= 0) Or (itmCnt < lwrOpt) Then lwrOpt = 0 If rtnOpt = 0 Then rtnOpt = Columns.Count - rtnCln + 1 '後方和配列 For i = 1 To itmCnt For j = i To itmCnt sumAry(i) = sumAry(i) + itmAry(j, 0) Next j Next i '予備探索(最少・最多調査) rtnLmt = 1 ReDim rtnAry(1 To itmCnt, 1 To rtnLmt) rtnCnt = 0 For i = 1 To itmCnt Call SampleScl(0, sumOpt, i, i) If rtnCnt = 1 Then Exit For Next i cntMin = i rtnCnt = 0 For i = itmCnt To 1 Step -1 Call SampleScl(0, sumOpt, i, i) If rtnCnt = 1 Then Exit For Next i cntMax = i '上限・下限値調整 If lwrOpt <= cntMin Then lwrOpt = 0 If uprOpt >= cntMax Then uprOpt = itmCnt '反転判定(基準はてきとー^^;) If (0 < lwrOpt) Eqv (uprOpt < itmCnt) Then rvsFlg = sumOpt * 2 > sumAry(1) ElseIf 0 < lwrOpt Then rvsFlg = sumOpt * 3 > sumAry(1) * 2 Else rvsFlg = sumOpt * 3 > sumAry(1) End If '反転するなら設定値入替 If rvsFlg Then sumOpt = sumAry(1) - sumOpt tmpSwp = uprOpt uprOpt = itmCnt - lwrOpt lwrOpt = itmCnt - tmpSwp End If '中断処理登録 On Error GoTo ERR1 Application.EnableCancelKey = xlErrorHandler rtnLmt = rtnOpt rtnCnt = 0 Erase rtnAry ReDim rtnAry(1 To itmCnt, 1 To rtnLmt) '子P呼び出し Select Case seqOpt Case 0 If (lwrOpt = 0) And (uprOpt = itmCnt) Then Call SampleScn(0, sumOpt) Else Call SampleScl(0, sumOpt, uprOpt, lwrOpt) End If Case Is > 0 For i = lwrOpt To uprOpt j = IIf(rvsFlg Eqv (seqOpt = 2), i, uprOpt + lwrOpt - i) Call SampleScl(0, sumOpt, j, j) Next i End Select '中断処理解除 On Error GoTo 0 Application.EnableCancelKey = xlInterrupt '書出し If rtnCnt > 0 Then dspLmt = Columns.Count - rtnCln + 1 dspLmt = IIf(rtnCnt < dspLmt, rtnCnt, dspLmt) ReDim dspAry(1 To orgCnt, 1 To dspLmt) '書出しテーブル作成 For i = 1 To dspLmt k = 1 For j = 1 To orgCnt If orgAry(j, 1) Then dspAry(IIf(dspOpt = 0, k, j), i) = orgAry(j, 0) k = k + 1 End If Next j For j = 1 To itmCnt If rtnAry(j, i) <> rvsFlg Then If dspOpt = 0 Then dspAry(k, i) = orgAry(itmAry(j, 1), 0) Else dspAry(itmAry(j, 1), i) = orgAry(itmAry(j, 1), 0) End If k = k + 1 End If Next j Next i Cells(1, rtnCln).Resize(orgCnt, dspLmt) = dspAry End If MsgBox _ "所要時間 " & Timer - t & " 秒" & vbCr & vbCr & _ rtnCnt & " 件 " & IIf(rtnCnt < rtnLmt, "", "以上") & " あります" Application.StatusBar = False Exit Sub ERR1: '中断処理 If Err.Number = 18 Then rtnCnt = rtnCnt - 1 rtnLmt = rtnCnt Resume Next Else MsgBox Err.Number & " " & Err.Description, vbCritical Application.EnableCancelKey = xlInterrupt Application.StatusBar = False End If End Sub '------------↓↑ ツヅク ↑↓------------ '無制限モード Private Sub SampleScn(ByVal itmIdx As Long, ByVal tmpSum As Long) Dim i As Long If rtnCnt = rtnLmt Then Exit Sub tmpSum = tmpSum - itmAry(itmIdx, 0) If tmpSum = 0 Then rtnCnt = rtnCnt + 1 For i = 1 To itmIdx If tmpAry(i) Then rtnAry(i, rtnCnt) = True Next i Application.StatusBar = "探索中 " & rtnCnt & " 件見つけました" Exit Sub End If For i = itmIdx + 1 To itmCnt If sumAry(i) < tmpSum Then Exit Sub If itmAry(i, 0) > tmpSum Then Exit Sub tmpAry(i) = True Call SampleScn(i, tmpSum) tmpAry(i) = False Next i End Sub '------------↓↑ ツヅク ↑↓------------ '制限モード Private Sub SampleScl(ByVal itmIdx As Long, ByVal tmpSum As Long, ByVal uprLmt As Long, ByVal lwrLmt As Long) Dim i As Long If rtnCnt = rtnLmt Then Exit Sub tmpSum = tmpSum - itmAry(itmIdx, 0) If tmpSum = 0 Then rtnCnt = rtnCnt + 1 For i = 1 To itmIdx If tmpAry(i) Then rtnAry(i, rtnCnt) = True Next i Application.StatusBar = "探索中 " & rtnCnt & " 件見つけました" Exit Sub End If If uprLmt < itmCnt - itmIdx - 1 Then If uprLmt = 0 Then Exit Sub If sumAry(itmCnt - uprLmt + 1) < tmpSum Then Exit Sub uprLmt = uprLmt - 1 End If If lwrLmt > 0 Then lwrLmt = lwrLmt - 1 For i = itmIdx + 1 To itmCnt - lwrLmt If sumAry(i) < tmpSum Then Exit Sub If itmAry(i, 0) > tmpSum Then Exit Sub If lwrLmt > 0 Then If sumAry(i) - sumAry(i + lwrLmt + 1) > tmpSum Then Exit Sub End If tmpAry(i) = True Call SampleScl(i, tmpSum, uprLmt, lwrLmt) tmpAry(i) = False Next i End Sub '----------------------↑ ココマデ ↑---------------------- 乗りかかった船なので一応対応してみましたが、 正直「高速化をしたい」という当初のご質問からは 少しずれてきたかなぁという印象です。 「作業依頼」や「続きの質問」で削除対象になっても詰まらないので、 【私としてはこれが最終案】ということにさせてください。 「追加要望」には応じられませんが、 バグがあれば対応しますのでご遠慮なく。 以上ご参考まで。長乱文・長乱コード陳謝。
- _Kyle
- ベストアンサー率78% (109/139)
またまた#4=5=6=7です(汗 締切まで1週間あるということなので、 私自身の実験や練習も兼ねて【ごっそり】直してみました。 「もうカスタマイズしちゃったし、現状速度で十分」 という場合は読み捨てていただいてもかまいません。 親Pがかなり長くなりましたが、ほとんどがコメント行と空行ですし、 上から下に一本道の処理で、個々の処理も深くはないので、 変にプロシージャを分割するより時系列に並べる方が、 (サンプルとして)可読性が高いと判断しました。 ●仕様の変更(オマケ機能いろいろ) ☆B列を設定列、C列をリスト列、D列以降を書出列にした。 ※設定項目が増え、項目見出しがないとつらくなったので。 ※冒頭の定数をいじれば元に戻せます。 ☆使用個数について「下限」=「最低幾つ使うか」も指定できるようにした。 ※上限と同様、空白または0の場合は制限無しで探索します。 ※上限と下限を同じ値にすれば「キッカリ」を探索します。 ☆使用個数が最少・最多となる組み合わせを探せるようにした。 ※個数制限と併用できます。 ・0または空白 ⇒ すべての組み合わせを探す ・1 ⇒ 使用個数が最も少ない組み合わせを探す ・2 ⇒ 使用個数が最も多い組み合わせを探す ☆書出し形式を選べるようにした。 ・0または空白 ⇒ 昇順上詰 ・1 ⇒ 降順上詰 ・2 ⇒ 元リストと同位置 ☆書出件数上限が「ワークシートの列数-5」件になった。 ※「見出列、設定列、リスト列、作業列×2」で5列使うので。 ☆設定セル位置まとめ ・B1 : 合計 ・B2 : 使用個数の上限 ・B3 : 使用個数の下限 ・B4 : 使用個数の最少/最多 ・B5 : 探索件数の上限 ・B6 : 書出形式 ※「処理速度」(探索速度)そのものは無制限探索の場合が最速です。 「所要時間」にどう影響するかは条件次第です。 ●動作の変更(処理速度向上) 【 分岐方法を一新した 】 こちらが主眼です。 旧バージョンは【 自身を使うか否か 】で分岐しますが、 新バージョンは【 次に使うものは何か 】で分岐します。 例によって「条件と設定次第」ですが、 探索速度としては、旧バージョンより相当程度速くなっています。 リストの個数が5,000個くらいでもサクサク結果を見つけてきます。 ただし、新旧で【結果の出てくる順番が違う】ので、 旧バージョン ⇒ 探索序盤に高率でヒット 新バージョン ⇒ 探索終盤に高率でヒット となるようなケースで、探索を途中で打ち切ると、 旧バージョンの方が速いように【 見える 】場合があります。 '----------------------↓ ココカラ ↓---------------------- Private Const optCln As Long = 2 '設定列の列番号 Private Const itmCln As Long = 3 'リスト列の列番号 Private Const rtnCln As Long = 4 '結果表示範囲の最左列の列番号 Private itmAry() As Long '要素配列 Private sumAry() As Long '後方和配列 Private tmpAry() As Boolean '経過配列 Private rtnAry() As Boolean '結果配列 Private itmCnt As Long '要素個数 Private rtnCnt As Long '結果件数 Private rtnLmt As Long '探索件数上限 '------------↓↑ ツヅク ↑↓------------ Sub Sample() Dim i As Long 'カウンタ Dim j As Long 'カウンタ Dim k As Long 'カウンタ Dim r As Long '書出行インデックス Dim t As Variant 'タイムカウンタ Dim orgSum As Long '初期合計 Dim uprLmt As Long '使用要素数上限 Dim lwrLmt As Long '使用要素数下限 Dim uprFlg As Boolean '上限フラグ Dim lwrFlg As Boolean '下限フラグ Dim rvsFlg As Boolean '反転フラグ Dim tmpSwp As Variant '入替退避用 Dim prsOpt As Long '最少最多設定 Dim prsLmt As Long '最少最多要素数 Dim rtnOpt As Long '探索件数設定 Dim dspOpt As Long '書出形式 Dim dspLmt As Long '書出件数上限 Dim dspAry As Variant '書出データ 'タイマスタート t = Timer '結果表示範囲をクリア Range(Columns(rtnCln), Columns(Columns.Count)).Clear '描画停止 Application.ScreenUpdating = False 'リストを作業列に転記(念のため) Columns(rtnCln).Value = Columns(itmCln).Value 'リスト個数取得 itmCnt = Cells(Rows.Count, rtnCln).End(xlUp).Row '初期位置書出 For i = 1 To itmCnt Cells(i, rtnCln + 1).Value = i Next i '転記したリスト列を初期行番号列と共に昇順ソート Columns(rtnCln).Resize(, 2).Sort _ Key1:=Cells(1, rtnCln), Order1:=xlAscending, Header:=xlNo '作業列を非表示 Columns(rtnCln).Resize(, 2).Hidden = True '描画再開 Application.ScreenUpdating = True '設定取得 orgSum = Cells(1, optCln).Value '初期合計 uprLmt = Cells(2, optCln).Value '使用要素数上限 lwrLmt = Cells(3, optCln).Value '使用要素数上限 prsOpt = Cells(4, optCln).Value '最少最多設定 rtnOpt = Cells(5, optCln).Value '探索件数設定 dspOpt = Cells(6, optCln).Value '書出形式設定 '配列要素数設定 Erase sumAry ReDim itmAry(0 To itmCnt) '子Pをゼロ始まりで呼ぶので ReDim tmpAry(1 To itmCnt) '先頭から前を見ることが無くなったので ReDim sumAry(1 To itmCnt + 1) '末尾から後を見ることがあるので '要素を取得 For i = 1 To itmCnt itmAry(i) = Cells(i, rtnCln) Next i '後方和配列作成 For i = 1 To itmCnt For j = i To itmCnt sumAry(i) = sumAry(i) + itmAry(j) Next j Next i '表示件数上限 dspLmt = Columns.Count - rtnCln - 1 '探索件数上限 rtnOpt = IIf(rtnOpt > 0, rtnOpt, dspLmt) '個数制限の有無 uprFlg = (0 < uprLmt And uprLmt < itmCnt) lwrFlg = (0 < lwrLmt And lwrLmt < itmCnt) If Not uprFlg Then uprLmt = itmCnt If Not lwrFlg Then lwrLmt = 0 '個数制限の有無と合計に応じて反転 If uprFlg = lwrFlg Then rvsFlg = orgSum * 2 > sumAry(1) ElseIf lwrFlg Then rvsFlg = orgSum * 3 > sumAry(1) * 2 Else rvsFlg = orgSum * 3 > sumAry(1) End If '反転処理をする場合は設定値入れ替え If rvsFlg Then orgSum = sumAry(1) - orgSum tmpSwp = uprLmt uprLmt = itmCnt - lwrLmt lwrLmt = itmCnt - tmpSwp tmpSwp = uprFlg uprFlg = lwrFlg lwrFlg = tmpSwp End If '予備探索(最少最多調査) If prsOpt > 0 Then Erase rtnAry rtnLmt = 1 ReDim rtnAry(1 To itmCnt, 1 To rtnLmt) If rvsFlg = (prsOpt = 2) Then '最少調査 For i = lwrLmt To uprLmt rtnCnt = 0 Call SampleS2(0, orgSum, i, i) If rtnCnt = 1 Then Exit For Next i Else '最多調査 For i = uprLmt To lwrLmt Step -1 rtnCnt = 0 Call SampleS2(0, orgSum, i, i) If rtnCnt = 1 Then Exit For Next i End If If rtnCnt = 0 Then prsOpt = 0 Else uprLmt = i lwrLmt = i prsLmt = IIf(rvsFlg, itmCnt - i, i) uprFlg = True lwrFlg = True End If End If '子P呼び出し rtnCnt = 0 Erase rtnAry rtnLmt = rtnOpt ReDim rtnAry(1 To itmCnt, 1 To rtnLmt) If uprFlg Or lwrFlg Then Call SampleS2(0, orgSum, uprLmt, lwrLmt) '制限モード Else Call SampleS1(0, orgSum) '無制限モード End If '結果書出し If rtnCnt > 0 Then '書出しテーブルの生成 dspLmt = IIf(rtnCnt < dspLmt, rtnCnt, dspLmt) ReDim dspAry(1 To itmCnt, 1 To dspLmt) For i = 1 To dspLmt k = 1 For j = 1 To itmCnt r = IIf(dspOpt = 1, itmCnt - j + 1, j) If rtnAry(r, i) <> rvsFlg Then dspAry(IIf(dspOpt = 2, r, k), i) = itmAry(r) k = k + 1 End If Next j Next i '書出し Cells(1, rtnCln + 2).Resize(itmCnt, dspLmt) = dspAry End If '元順表示なら初期行位置で再ソート If dspOpt = 2 Then Columns(rtnCln).Resize(, 2 + dspLmt).Sort _ Key1:=Cells(1, rtnCln + 1), Order1:=xlAscending, Header:=xlNo End If '作業列を削除 Columns(rtnCln).Resize(, 2).Delete '結果表示 MsgBox _ "所要時間 " & Timer - t & " 秒" & vbCr & vbCr & _ IIf(prsOpt = 1, "個数は " & prsLmt & " 個が 最少です" & vbCr & vbCr, "") & _ IIf(prsOpt = 2, "個数は " & prsLmt & " 個が 最多です" & vbCr & vbCr, "") & _ rtnCnt & " 件 " & IIf(rtnCnt < rtnLmt, "", "以上") & " あります" Application.StatusBar = False End Sub '------------↓↑ ツヅク ↑↓------------ '無制限モード Sub SampleS1(ByVal itmIdx As Long, ByVal tmpSum As Long) Dim i As Long 'カウンタ '件数上限に達しているならアウト If rtnCnt = rtnLmt Then Exit Sub 'まず減らす tmpSum = tmpSum - itmAry(itmIdx) 'ヒット判定 If tmpSum = 0 Then rtnCnt = rtnCnt + 1 Application.StatusBar = "探索中 " & rtnCnt & " 件見つけました" For i = 1 To itmIdx If tmpAry(i) Then rtnAry(i, rtnCnt) = True Next i Exit Sub End If '次に使うものを選ぶ For i = itmIdx + 1 To itmCnt 'i以降の全てを使っても足りないならアウト If sumAry(i) < tmpSum Then Exit Sub 'i以降のどれを使っても超えるならアウト If itmAry(i) > tmpSum Then Exit Sub '次にiを使って進む tmpAry(i) = True Call SampleS1(i, tmpSum) 'フラグを倒してから次のiへ tmpAry(i) = False Next i End Sub '------------↓↑ ツヅク ↑↓------------ '制限モード Sub SampleS2(ByVal itmIdx As Long, ByVal tmpSum As Long, ByVal uprLmt As Long, ByVal lwrLmt As Long) Dim i As Long 'カウンタ '件数上限に達しているならアウト If rtnCnt = rtnLmt Then Exit Sub 'まず減らす tmpSum = tmpSum - itmAry(itmIdx) 'ヒット判定 If tmpSum = 0 Then rtnCnt = rtnCnt + 1 Application.StatusBar = "探索中 " & rtnCnt & " 件見つけました" For i = 1 To itmIdx If tmpAry(i) Then rtnAry(i, rtnCnt) = True Next i Exit Sub End If '上限アリの場合に… If uprLmt < itmCnt - itmIdx - 1 Then '要素上限に達していたならアウト If uprLmt = 0 Then Exit Sub '要素上限に達する最大の組み合わせを使っても足りないならアウト If sumAry(itmCnt - uprLmt + 1) < tmpSum Then Exit Sub '要素上限更新 uprLmt = uprLmt - 1 End If '要素下限更新 If lwrLmt > 0 Then lwrLmt = lwrLmt - 1 '次に使うものを選ぶ For i = itmIdx + 1 To itmCnt - lwrLmt 'i以降の全てを使っても足りないならアウト If sumAry(i) < tmpSum Then Exit Sub 'i以降のどれを使っても超えるならアウト If itmAry(i) > tmpSum Then Exit Sub 'i以降で要素下限に達する最小の組合わせを使っても超えるならアウト If lwrLmt > 0 Then If sumAry(i) - sumAry(i + lwrLmt + 1) > tmpSum Then Exit Sub End If '次にiを使って進む tmpAry(i) = True Call SampleS2(i, tmpSum, uprLmt, lwrLmt) 'フラグを倒してから次のiへ tmpAry(i) = False Next i End Sub '----------------------↑ ココマデ ↑---------------------- ●余談 実は、ほぼ1年前に、似たような(もう少し単純な)質問がありまして そのときは最初からこの形の分岐で書きました。 (http://oshiete1.goo.ne.jp/qa3557520.html の#3) 今回も当初その方向で始めたのですが、 処理速度を追求するケースで 「カンマ区切のStringをVariant配列にしてリレー」 なんて無茶はさすがにできませんし、 tpAry(tmpAry)の取り回しで混乱してしまって、保留していました。 フラグを倒してから回せばいいだけのハナシだったとは…(苦笑 以上ご参考まで。長乱文&長乱コード陳謝
補足
さらに改造をしていただいてありがとうございます。 まだ、今回のを試しておりませんが、1つ前のコードを試させていただきました。かなりいい出来です。 とりあえず、お礼を、このたびも「ありがとうございます。」 前回のコードを試させていただいた結果、もし可能ならこんなことも できたらなぁというものがありました。 どうなのか意見を聞かせてください。 ○当初に参考にしていたコードのように、備考のような(なんの金額なのか)コメントを数字の隣に表記したときに、検索結果として一緒に出力されると、結果を見たときに何の金額なのかわかっていいな~と思いました。ただ、そうすると出力結果を表示するセルが足りないのかな~。 ○処理途中で「ESC」で、抜けたときも、そこまでの結果を表示できないか。 ○結果を出力する場合、組み合わせ個数の少ないものから順番に表記できないか。 ○組み合わせ結果に、リストにある金額をあらかじめ指定できないか。 (ex:合計が10になる組み合わせを探すとき、リストにある「2」という数字が入った組み合わせだけを調べる。-2を指定できる-) ○検索に使うB列のリスト範囲を指定できる。(いまは、数字が入っているセルまでの個数すべてを組み合わせる数字としているが、たとえばB1:B10までの10個を調査対象とするなどと指定できる)。 以上です。 無理な場合は読み流していただいて構いません。 早速、改良していただいたコードを試させていただきます。 感想、また書き込みます。
- _Kyle
- ベストアンサー率78% (109/139)
#4=5=6です。 何度もすみません。再々訂正です。 「制限ナシ」用の子プロシージャ SampleF について、 「残りのどれを使っても超えるならアウト」の判定が、 IFの方とSelectCaseの方と2つあります。 IFステートメントの方は不要ですので削除してください。 '----------------------↓ 削除ココカラ ↓---------------------- '残りのどれを使っても超えるならアウト If imAry(imIdx) > imSum Then Exit Sub '----------------------↑ 削除ココマデ ↑---------------------- ※元の状態でも少し遅くなるだけできちんと動作はします。 よくわからなければそのまま残してもかまいません。 ※「制限アリ-反転」SampleF2,「制限アリ-通常」SampleF3については 必要な判定ですのでそのまま残してください。 …ちょっと泣けてきました。
補足
途中で仕様を変更するというのは、自分も低レベルなマクロを 組んでいて、かなり嫌なものです。 要望を出したにもかからわず、仕様を変更し、再アップして くださって、本当に感謝しております。 また、ご丁寧に訂正までしてくださり、お心遣いに感激です。 1週間ほど仕事でネットの使えない環境になりますが、今回の _Kyleさんのプログラムを十分に使わせていただき、感想・要望を またまた書き込みさせていただきます。 結構、いろんなページ・サイトを探したのですが、なかなか今回 のお題に見合うページがなく、困って投稿しました。 たぶん、この質問を参考にされいてる方が多数いらっしゃると 思います。 _Kyleさん、ほんとうにありがとうございます。 では、来週末また書き込みます。
- _Kyle
- ベストアンサー率78% (109/139)
#4=5です。 ●まずは謝罪と訂正から。 【 #5ですが、訂正した上でなお違ってました 】 というより直っていませんでした。重ねてすみません。 原因はflAryではなくrvFlgが立ちっぱになることでした。 ●次に、使用要素数の制限について 使用要素数を制限して早くなるかどうかは、 条件(リストの数,分布)と設定(合計,上限)によります。 (アルゴリズムとコーディングにもよりますが^^;;) 補足にあるように 「該当する組み合わせのうち上限を超えるもの(ex.{1,2,3,4})を無視する」 という意味(場合)なら 【適当な値を設定すれば、多くの場合】所要時間は短くなると思います。 一方、意図的に、あるいは結果として「無制限の場合と同じ結果になる」場合、 例えば、 「要素数100個、(結果として)該当する組み合わせが全て20個以下の要素からなる」 というケースで上限を25としたような場合は、【多くの場合、むしろ遅くなる】と思います。 総当り方式と違い、底まで全部なめているわけではありませんから、 可能性のない部分はもともと見ていません。 使用要素数を制限すれば回す回数そのものは(多くの場合)減るのですが、 回しながらカウントしたり判定したりすることになりますから、1回あたりの処理は遅くなります。 条件によっては「一部を探すより、全部探す方が速い」というような逆転も起こりえます。 また、ランダムデータでテストした感じでは、 使用要素数自体それほどバラつきが出ないようです。 つまり、当てずっぽうで使用要素数を制限しても、 「まったくヒットしない」か「結局全部見つける」か両極端になりそうです。 ただ、書き出しきれないほど該当件数が多い場合に 「結果を絞って目的のもの(?)をみつける」とか 「無いなら無いで、無いということが知りたい」とか そういう用途には使えそうなので直してみました。 以下は仕様変更版です。 ■A2セルに使用要素数の上限を設定してください。 空白あるいは0の場合は無制限で探索します。 ■A3セルに結果書出件数の上限を設定してください。 空白あるいは0の場合は最終列まで書出します。 その他の変更点 ・flAryをVariant型に変更。 ・「自身が最後の要素かどうか」の判定削除(不要な判定でした。) ・出血大サービスでコメントを追加 同じようなサブを3つも並べる間抜けな構造ですが、 変に判定や分岐を混ぜると重くなりそうなのと、 ごちゃごちゃして面倒くさくなったので…。 実際のところ私自身少々混乱気味で、個数を制限する場合については 「出てきたものは必ず条件を満たす」だろうとは思うのですが、 「条件を満たすものは必ず出てくる」かどうか、イマイチ確信を持てません。 もし、「条件を満たすのにヒットしない」ケースがありましたら、 ・リストの内容(順番通りに) ・合計 ・使用個数上限 ・ヒットしない組み合わせ を補足してくだされば、可能な限り対応します。 '----------------------↓ ココカラ ↓---------------------- '宣言部 Dim imAry() As Long '要素 Dim smAry() As Long '後方部分和 Dim tpAry() As Boolean '経過 Dim rtAry() As Boolean '結果 Dim imCnt As Long '要素数 Dim rtCnt As Long '結果数 Dim tpCnt As Long '使用要素数 Dim imLmt As Long '使用要素上限 Dim rtLmt As Long '書出件数上限 Dim rvFlg As Boolean '反転フラグ Dim i As Long '汎用カウンタ Dim j As Long '汎用カウンタ Sub Sample() '宣言 Dim t As Variant 'タイムカウンタ Dim k As Long 'カウンタ Dim ogRng As Range 'リスト範囲 Dim tpSum As Long '合計 Dim flAry As Variant '書出データ '書出範囲初期化 Range(Columns(3), Columns(Columns.Count)).Clear 'リスト範囲取得 Set ogRng = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp)) imCnt = ogRng.Cells.Count '要素数取得 '変数初期処理 ReDim imAry(1 To imCnt) ReDim tpAry(0 To imCnt) '先頭要素から前を見ることがある ReDim smAry(1 To imCnt + 1) '末尾要素から後を見ることがある Erase rtAry t = Timer rtCnt = 0 tpCnt = 0 '要素を昇順で取得 For i = 1 To imCnt imAry(i) = Application.Small(ogRng, i) Next i tpSum = Cells(1, 1).Value '合計を取得 imLmt = Cells(2, 1).Value '使用要素上限を取得 '書出件数上限を設定 If Cells(3, 1).Value > 0 Then rtLmt = Cells(3, 1).Value Else rtLmt = Columns.Count - 2 End If '後方部分和の配列を作成 For i = 1 To imCnt For j = i To imCnt smAry(i) = smAry(i) + imAry(j) Next j Next i '合計が大きい場合は反転処理(基準は要再考?) If smAry(1) < tpSum * 2 Then tpSum = smAry(1) - tpSum rvFlg = True Else rvFlg = False End If '子P呼び出し If imLmt = 0 Then Call SampleF(1, tpSum) '制限ナシ Else If rvFlg Then imLmt = imCnt - imLmt Call SampleF2(1, tpSum) '制限アリ-反転 Else Call SampleF3(1, tpSum) '制限アリ-通常 End If End If '書出しテーブルの生成 ⇒ 書出し If rtCnt > 0 Then ReDim flAry(1 To imCnt, 1 To rtCnt) For i = 1 To rtCnt k = 1 For j = 1 To imCnt If rtAry(j, i) <> rvFlg Then flAry(k, i) = imAry(j) k = k + 1 End If Next j Next i Columns(3).Resize(imCnt, rtCnt) = flAry End If '結果表示 MsgBox _ "所要時間 " & Timer - t & " 秒" & vbCr & vbCr & _ rtCnt & " 件 " & IIf(rtCnt < rtLmt, "", "以上") & " あります" Application.StatusBar = False End Sub '制限ナシ Sub SampleF(ByVal imIdx As Integer, ByVal imSum As Long) '残り全てを使っても足りないならアウト If smAry(imIdx) < imSum Then Exit Sub '残りのどれを使っても超えるならアウト If imAry(imIdx) > imSum Then Exit Sub Select Case imAry(imIdx) - imSum '残りのどれを使っても超えるならアウト Case Is > 0 Exit Sub 'ヒット! Case 0 rtCnt = rtCnt + 1 Application.StatusBar = "探索中 " & rtCnt & " 件見つけました" ReDim Preserve rtAry(1 To imCnt, 1 To rtCnt) For i = 1 To imIdx - 1 If tpAry(i) Then rtAry(i, rtCnt) = True Next i rtAry(i, rtCnt) = True Exit Sub End Select '件数上限に達したならアウト If rtCnt = rtLmt Then Exit Sub '自身を使わずに進む tpAry(imIdx) = False Call SampleF(imIdx + 1, imSum) '自身を使って進む tpAry(imIdx) = True Call SampleF(imIdx + 1, imSum - imAry(imIdx)) End Sub '制限アリ-反転 Sub SampleF2(ByVal imIdx As Integer, ByVal imSum As Long) '残り全てを使っても合計に足りないならアウト If smAry(imIdx) < imSum Then '残りのどれを使っても合計を超えるならアウト ElseIf imAry(imIdx) > imSum Then '残り全てを使っても要素下限に達しないならアウト ElseIf imLmt - (imCnt - imIdx + 1) > 0 Then '要素下限に達する最小の組み合わせを使っても合計を超えるならアウト ElseIf smAry(imIdx) - smAry(imIdx + IIf(imLmt < 0, 0, imLmt)) > imSum Then 'ヒット ElseIf imAry(imIdx) = imSum Then rtCnt = rtCnt + 1 Application.StatusBar = "探索中 " & rtCnt & " 件見つけました" ReDim Preserve rtAry(1 To imCnt, 1 To rtCnt) For i = 1 To imIdx - 1 If tpAry(i) Then rtAry(i, rtCnt) = True Next i rtAry(i, rtCnt) = True '件数の上限に達していたならアウト ElseIf rtCnt = rtLmt Then '先に進む Else '自身を使わずに進む tpAry(imIdx) = False Call SampleF2(imIdx + 1, imSum) '自身を使って進む tpAry(imIdx) = True imLmt = imLmt - 1 Call SampleF2(imIdx + 1, imSum - imAry(imIdx)) End If '要素下限更新 imLmt = imLmt + IIf(tpAry(imIdx - 1), 1, 0) End Sub '制限アリ-通常 Sub SampleF3(ByVal imIdx As Integer, ByVal imSum As Long) '残り全てを使っても合計に足りないならアウト If smAry(imIdx) < imSum Then '残りのどれを使っても合計を超えるならアウト ElseIf imAry(imIdx) > imSum Then '要素上限に達していたならアウト ElseIf imLmt = 0 Then '要素上限に達する最大の組み合わせを使っても合計に足りないならアウト ElseIf smAry(imCnt - imLmt + 1) < imSum Then 'ヒット ElseIf imAry(imIdx) = imSum Then rtCnt = rtCnt + 1 Application.StatusBar = "探索中 " & rtCnt & " 件見つけました" ReDim Preserve rtAry(1 To imCnt, 1 To rtCnt) For i = 1 To imIdx - 1 If tpAry(i) Then rtAry(i, rtCnt) = True Next i rtAry(i, rtCnt) = True '件数の上限に達していたならアウト ElseIf rtCnt = rtLmt Then '先に進む Else '自身を使わずに進む tpAry(imIdx) = False Call SampleF3(imIdx + 1, imSum) '自身を使って進む tpAry(imIdx) = True imLmt = imLmt - 1 Call SampleF3(imIdx + 1, imSum - imAry(imIdx)) End If '要素上限更新 imLmt = imLmt + IIf(tpAry(imIdx - 1), 1, 0) End Sub '----------------------↑ ココマデ ↑---------------------- ●「素人の手すさび」というのは私のハナシです、念のため。 >_Kyleさんはプログラマの方でしょうか? まさか!(笑 「初心者に毛が生えかけた状態」のまま○年という文系事務屋です。 過去質#6さんのコードより速いといっても、 あちらは1つ見つければ良い(?)ケースで、要求仕様が違いますから、 私のコードの方が優れているというわけではありません。 "プログラマ"というのは、 「モジュールレベル変数の初期化でしくじったり」 「long型配列を貼り付けて置換で0を抜いたり」 しない人たちのことです(苦笑 以上ご参考まで。長乱文&長乱コード陳謝
- _Kyle
- ベストアンサー率78% (109/139)
#4です。 スミマセン、連続して起動するとflAryにデータが残っちゃいますね。 修正しました。 '----------------------↓ ココカラ ↓---------------------- Dim imAry() As Long Dim tpAry() As Boolean Dim rtAry() As Boolean Dim smAry() As Long Dim imCnt As Long Dim rtCnt As Long Dim rtLmt As Long Dim rvFlg As Boolean Dim i As Long Dim j As Long Dim k As Long Dim t As Variant Sub Sample() Dim ogRng As Range Dim tpSum As Long Dim flAry() As Long Range("C:IV").Clear rtLmt = 254 Set ogRng = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp)) imCnt = ogRng.Cells.Count ReDim imAry(imCnt) ReDim tpAry(imCnt) ReDim smAry(imCnt) For i = 1 To imCnt imAry(i) = Application.Small(ogRng, i) Next i For i = 1 To imCnt For j = i To imCnt smAry(i) = smAry(i) + imAry(j) Next j Next i tpSum = Cells(1, 1).Value If (smAry(1) / 2) < tpSum Then tpSum = smAry(1) - tpSum rvFlg = True End If t = Timer rtCnt = 0 Erase rtAry Erase flAry Call SampleF(1, tpSum) If rtCnt > 0 Then ReDim flAry(1 To imCnt, 1 To rtCnt) For i = 1 To rtCnt k = 1 For j = 1 To imCnt If rtAry(j, i) <> rvFlg Then flAry(k, i) = imAry(j) k = k + 1 End If Next j Next i ogRng.Offset(0, 1).Resize(, rtCnt) = flAry Range("C:IV").Replace "0", "", xlWhole End If MsgBox _ "所要時間 " & Timer - t & " 秒" & vbCr & vbCr & _ rtCnt & " 件" & IIf(rtCnt < rtLmt, " あります", " 以上あります") Application.StatusBar = False End Sub Sub SampleF(ByVal imIdx As Integer, ByVal imSum As Long) If smAry(imIdx) < imSum Then Exit Sub If rtCnt = rtLmt Then Exit Sub Select Case imAry(imIdx) - imSum Case Is > 0 Exit Sub Case 0 rtCnt = rtCnt + 1 Application.StatusBar = "探索中 " & rtCnt & " 件見つけました" ReDim Preserve rtAry(1 To imCnt, 1 To rtCnt) For i = 1 To imIdx - 1 If tpAry(i) Then rtAry(i, rtCnt) = True Next i rtAry(i, rtCnt) = True Exit Sub End Select If imIdx < imCnt Then tpAry(imIdx) = False Call SampleF(imIdx + 1, imSum) tpAry(imIdx) = True Call SampleF(imIdx + 1, imSum - imAry(imIdx)) End If End Sub '----------------------↑ ココマデ ↑----------------------
補足
レスありがとうございます。 すばらしいです。格段に速くなっています。 _Kyleさんはプログラマの方でしょうか? わたしは素人なので、どこをいじっていいかわからないのですが、 たとえば、合計を探し出す際に、組み合わせる数字の数を指定したら、 より処理は速くなりますか? (ex.組み合わせる数を3個とする= 合計10を求める場合、○1、9 ○2、3、5 ×1、2、3、4) 合計を求める際の組み合わせるリストの最大個数を、セル入力で、 指定することは可能ですか?
- _Kyle
- ベストアンサー率78% (109/139)
「実用」に耐えるかどうかはわかりませんが、 (質問1229646の#6さんのコードに較べて)多少は速くなったようなのでとりあえず。 A1に合計、B列に1行目からリスト、結果をC列から右に昇順上詰で書き出す仕様です。 ヨタヨタしたコードですが、所詮素人の手すさびなのでご容赦ください。 私の環境でテストしたところでは、 ・リスト:1,000個(十万以下のランダムな自然数) ・合 計:50,440,000 ・該当数:129通り というケースでは、0.6秒ほどで、全ての組み合わせを見つけることができました。 ただし、リストの個数が少なくても、該当する組み合わせが多い場合 例えば ・リスト:100個(十万以下のランダムな自然数) ・合 計:5,100,000 ・該当数:254,380通り というケースでは、80分ほど要します。 こちらも毎秒53件ですからペースとしては悪くないんですが、何せ件数が多いので。 総当り式ではありませんから、リストの個数それ自体よりも、 「合計」の大きさや「結果の件数」が所要時間に影響します。 質問1229646の#6さんのコードとの主な相違点 ・逐次書き出すのではなく、最後に一括して書き出す。 ⇒「固まった」ように見えるのでステイタスバーに進捗を表示するようにした。 ・「残りのどれを使っても超える」場合に抜ける。 ・「残りの全てを使っても足りない」場合に抜ける。 ・「合計」の大きさによっては「使わないものの組み合わせ」を探す。 ・(書き出す場所の都合でとりあえず)254件までで探索を打ち切る。 '----------------------↓ ココカラ ↓---------------------- Dim imAry() As Long Dim tpAry() As Boolean Dim rtAry() As Boolean Dim smAry() As Long Dim imCnt As Long Dim rtCnt As Long Dim rtLmt As Long Dim rvFrg As Boolean Dim i As Long Dim j As Long Dim k As Long Dim t As Variant Sub Sample() Dim ogRng As Range Dim tpSum As Long Dim flAry() As Long Range("C:IV").Clear rtLmt = 254 Set ogRng = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp)) imCnt = ogRng.Cells.Count ReDim imAry(imCnt) ReDim tpAry(imCnt) ReDim smAry(imCnt) For i = 1 To imCnt imAry(i) = Application.Small(ogRng, i) Next i For i = 1 To imCnt For j = i To imCnt smAry(i) = smAry(i) + imAry(j) Next j Next i tpSum = Cells(1, 1).Value If (smAry(1) / 2) < tpSum Then tpSum = smAry(1) - tpSum rvFrg = True End If t = Timer rtCnt = 0 Erase rtAry Call SampleF(1, tpSum) If rtCnt > 0 Then ReDim flAry(1 To imCnt, 1 To rtCnt) For i = 1 To rtCnt k = 1 For j = 1 To imCnt If rtAry(j, i) <> rvFrg Then flAry(k, i) = imAry(j) k = k + 1 End If Next j Next i ogRng.Offset(0, 1).Resize(, rtCnt) = flAry Range("C:IV").Replace "0", "", xlWhole End If MsgBox _ "所要時間 " & Timer - t & " 秒" & vbCr & vbCr & _ rtCnt & " 件" & IIf(rtCnt < rtLmt, " あります", " 以上あります") Application.StatusBar = False End Sub Sub SampleF(ByVal imIdx As Integer, ByVal imSum As Long) If smAry(imIdx) < imSum Then Exit Sub If rtCnt = rtLmt Then Exit Sub Select Case imAry(imIdx) - imSum Case Is > 0 Exit Sub Case 0 rtCnt = rtCnt + 1 Application.StatusBar = "探索中 " & rtCnt & " 件見つけました" ReDim Preserve rtAry(1 To imCnt, 1 To rtCnt) For i = 1 To imIdx - 1 If tpAry(i) Then rtAry(i, rtCnt) = True Next i rtAry(i, rtCnt) = True Exit Sub End Select If imIdx < imCnt Then tpAry(imIdx) = False Call SampleF(imIdx + 1, imSum) tpAry(imIdx) = True Call SampleF(imIdx + 1, imSum - imAry(imIdx)) End If End Sub '----------------------↑ ココマデ ↑---------------------- 以上ご参考まで。長乱文陳謝。
A列にリスト、B1セルに目標値を入力しておく。 目標値以下で最大になるような組み合わせを1つだけC列に書き出す。 (その目標値になるような組み合わせが何通りかあっても、1つだけしか出せない。) Sub BubunSyuugouWa() '部分集合和 Const n As Integer = 100 'リスト範囲=A1:An Dim x As Long '目標値=B1セルの値 Dim Dic As Object, dicKey 'dictionary Dim arr '配列 Dim xx As Long '途中経過 Dim i As Integer, j As Long Set Dic = CreateObject("scripting.dictionary") x = Range("b1").Value arr = Range("a1").Resize(n).Value With Dic .Add 0, 0 i = 1 'To n Do '計算開始 For Each dicKey In .keys j = dicKey + arr(i, 1) 'j = 和 If j <= x And Not .exists(j) Then '和が目標値以下なら .Add j, i '辞書に追加 If j > xx Then xx = j Application.StatusBar = xx '途中経過をステータスバーに表示 If j = x Then Exit Do '目標値ぴったりなら計算終了 End If End If Next i = i + 1 Loop While i <= n For i = n To 1 Step -1 If i = .Item(xx) Then xx = xx - arr(i, 1) Else arr(i, 1) = "" End If Next i End With 'Dic Set Dic = Nothing With Range("c1").Resize(n) .Select: .Value = arr '組み合わせ出力 End With Application.CommandBars("AutoCalculate").Controls(7).Execute Application.StatusBar = False End Sub アルゴリズムは"動的計画法"っつーのです(多分)。 どのくらい時間かかるかは、データによるので一概に言えません。 30個位なら、あっという間に終わります。
補足
レスありがとうございます。 できましたら、やはり、複数の組み合わせがでたほうがいいですね。 その合計を構成する数の組み合わせをリストから探しだすというのが もくてきですので、、、
- imogasi
- ベストアンサー率27% (4737/17069)
エクセルのマクロの問題ではなく、数学的アルゴリズムの問題だと思います。ここエクセルのコーナーに質問するのは見当ハズレと思います。 小生は具体的回答はおぼつかないですが、ここに質問しても、という 点はわかります。 ここはエクセルの操作とか、ビジネス利用の簡単な質問のコーナーで、答えているのも、文系プログラマーがほとんどではないですか。たまたま、勉強している人が読者におれば良いですが。この質問コーナーを読んでいる人は専門家で現役バリバリの人はほとんど居ないはずです。質問を読むだけでも随分時間がとられて、仕事が出来ないはずですから。 こういうのは、数学的(特に組み合わせ論は特別?)なセンスを勉強して訓練して居る人に聞くべきです。数学などのコーナーに聞いてみたらと思います。 処理する(計算量を少なくする)アイデア・工夫が(もしあったとすれば)大事です。まともに計算すれば、処理時間などの面で破綻は免れないでしょう。 全く別問題ですが、その頂点は有名なダイクストラ法(最短経路問題)のようなイメージです。 全く想像ですが、あるいは将棋ソフトのような処理も参考になるのかも知れません。その時点以後について、見込みのないコースをいかに早く見つけて、その線の処理を打ち切るかが大切なのかなと思います。 まともに計算する方法(総尽くし法?)のコードは、その路線ではほとんど改良の余地はないでしょう(画面表示などを抑止するぐらいか、高速マシンを選ぶ。それもパソコンでは数倍程度アップか)。
- rukuku
- ベストアンサー率42% (401/933)
はじめまして 数年前に作ったマクロですので、当時のパソコンの処理の処理能力を考えて、リストの数を30に制限しています。 今でのパソコンは処理の能力が上がっているので、リストの数が増えても大丈夫だと思います。 どんな方法で?というのはという原理についてはゴメンナサイ、忘れました。 Option Explicit Sub 未払い請求書の組み合わせ() Dim Sousu As Long '請求書総数 Dim Fusoku As Long '不足分の枚数 Dim FusokuMax As Long '不足分の枚数の最大 Dim a(255) As Integer Dim i As Long Dim j As Long Dim l As Long Dim Combination As Long Dim Seikyugaku As Currency Dim Fusokugaku As Currency '総数の取得と不足分の最大数の設定 [Sheet1].Activate Sousu = [Sheet1].UsedRange.Rows.Count If Sousu > 30 Then MsgBox ("31枚以上は扱えません") Exit Sub End If Fusoku = 0 Combination = 0 Do While Combination < 65534 FusokuMax = Fusoku If FusokuMax = Sousu Then Exit Do Fusoku = Fusoku + 1 Combination = Combination + WorksheetFunction.Combin(Sousu, Fusoku) Loop MsgBox ("最大" & FusokuMax & "枚不足まで組み合わせを求めます") 'シートの初期設定 [Sheet2].Activate [Sheet2].UsedRange.ClearContents Cells(2, 33).Value = Time ''タイトル行の設定 With Columns("A:AD") .ColumnWidth = 2 .ShrinkToFit = True .VerticalAlignment = xlCenter End With Columns("AE:AG").ColumnWidth = 18 Columns("AE:AF").NumberFormatLocal = "\#,##0;\-#,##0" Columns("AG:AG").NumberFormatLocal = "h:mm:ss" Rows("1:1").Font.Bold = True Range("A2").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True For i = 1 To Sousu Cells(1, i) = i Next i Range("AE1") = "不足金額" Range("AF1") = "支払済金額" Range("AG1") = "開始/終了" '組み合わせを求める l = 2 For Fusoku = 1 To FusokuMax For i = 1 To Fusoku a(i) = i Next l = l + 1 For i = 1 To Fusoku Cells(l, a(i)) = "X" Next i Do Until a(1) = Sousu - (Fusoku - 1) For i = Fusoku To 1 Step -1 If a(i) < Sousu - (Fusoku - i) _ Then a(i) = a(i) + 1 For j = i + 1 To Fusoku a(j) = a(j - 1) + 1 Next j l = l + 1 For j = 1 To Fusoku Cells(l, a(j)) = "X" Next j Exit For End If Next i Loop Next Fusoku '組み合わせに対する不足額の計算 Seikyugaku = WorksheetFunction.Sum([Sheet1].Range("A:A")) For i = 2 To l Fusokugaku = 0 For j = 1 To FusokuMax If Cells(i, j) = "X" Then Fusokugaku = Fusokugaku + [Sheet1].Cells(j, 1) Next j Cells(i, 31) = Fusokugaku Cells(i, 32) = Seikyugaku - Fusokugaku Next i Cells(3, 33).Value = Time End Sub
お礼
_Kyleさんのおっしゃる通り、当初のテーマとは私自身の発言もずれてきてしまいました。 _Kyleにどっぷりと甘えてしまいました。 どんどん、要望通りにマクロを修正できるスキルの高さに、ついつい興奮して要望を出してしまいました。 今回の回答には、本当に助かりました。ありがとうございます。 あとはマクロを少しずつ勉強して、自分で理解して使わせていただきたいと思います。 最終版も大事に使わせていただいて、わからないところがあればマクロについて質問させていただきます。 本当にありがとうございました。
補足
申し訳ありませんが、オーバーフローをしてしまう場合があるのですが、リストの数字の桁数が多いのでしょうか? >sumAry(i) = sumAry(i) + itmAry(j, 0) の場所で止まってしまいます。 該当の変数のLomg型をもっと大きいものに変えればいいのでしょうか。