- ベストアンサー
エクセルマクロの高速化をしたい
合計の数字を指定し、リストからどの数字の組み合わせか抽出する マクロを作成中です。 ↓の質問を参考にしています。 http://oshiete1.goo.ne.jp/qa1229646.html やり方はすごく参考になるのですが、処理速度が遅く、実用的には だいたい３０個の数字リスト程度が限度です。 １００個の数字リストから組み合わせを抽出できるように マクロの高速化ははかれないものでしょうか？
- みんなの回答 （10）
- 専門家の回答
質問者が選んだベストアンサー
その他の回答 (9)
- _Kyle
- ベストアンサー率78% (109/139)
- _Kyle
- ベストアンサー率78% (109/139)
またまた#4=5=6=7です（汗 締切まで１週間あるということなので、 私自身の実験や練習も兼ねて【ごっそり】直してみました。 「もうカスタマイズしちゃったし、現状速度で十分」 という場合は読み捨てていただいてもかまいません。 親Pがかなり長くなりましたが、ほとんどがコメント行と空行ですし、 上から下に一本道の処理で、個々の処理も深くはないので、 変にプロシージャを分割するより時系列に並べる方が、 （サンプルとして）可読性が高いと判断しました。 ●仕様の変更（オマケ機能いろいろ） ☆B列を設定列、C列をリスト列、D列以降を書出列にした。 ※設定項目が増え、項目見出しがないとつらくなったので。 ※冒頭の定数をいじれば元に戻せます。 ☆使用個数について「下限」＝「最低幾つ使うか」も指定できるようにした。 ※上限と同様、空白または0の場合は制限無しで探索します。 ※上限と下限を同じ値にすれば「キッカリ」を探索します。 ☆使用個数が最少・最多となる組み合わせを探せるようにした。 ※個数制限と併用できます。 ・0または空白 ⇒ すべての組み合わせを探す ・1 ⇒ 使用個数が最も少ない組み合わせを探す ・2 ⇒ 使用個数が最も多い組み合わせを探す ☆書出し形式を選べるようにした。 ・0または空白 ⇒ 昇順上詰 ・1 ⇒ 降順上詰 ・2 ⇒ 元リストと同位置 ☆書出件数上限が「ワークシートの列数－５」件になった。 ※「見出列、設定列、リスト列、作業列×２」で５列使うので。 ☆設定セル位置まとめ ・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 '子Ｐ呼び出し 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 '----------------------↑ ココマデ ↑---------------------- ●余談 実は、ほぼ１年前に、似たような（もう少し単純な）質問がありまして そのときは最初からこの形の分岐で書きました。 （http://oshiete1.goo.ne.jp/qa3557520.html の#3） 今回も当初その方向で始めたのですが、 処理速度を追求するケースで 「カンマ区切のStringをVariant配列にしてリレー」 なんて無茶はさすがにできませんし、 tpAry(tmpAry)の取り回しで混乱してしまって、保留していました。 フラグを倒してから回せばいいだけのハナシだったとは…（苦笑 以上ご参考まで。長乱文＆長乱コード陳謝
補足
さらに改造をしていただいてありがとうございます。 まだ、今回のを試しておりませんが、１つ前のコードを試させていただきました。かなりいい出来です。 とりあえず、お礼を、このたびも「ありがとうございます。」 前回のコードを試させていただいた結果、もし可能ならこんなことも できたらなぁというものがありました。 どうなのか意見を聞かせてください。 ○当初に参考にしていたコードのように、備考のような（なんの金額なのか）コメントを数字の隣に表記したときに、検索結果として一緒に出力されると、結果を見たときに何の金額なのかわかっていいな～と思いました。ただ、そうすると出力結果を表示するセルが足りないのかな～。 ○処理途中で「ESC」で、抜けたときも、そこまでの結果を表示できないか。 ○結果を出力する場合、組み合わせ個数の少ないものから順番に表記できないか。 ○組み合わせ結果に、リストにある金額をあらかじめ指定できないか。 （ex:合計が１０になる組み合わせを探すとき、リストにある「２」という数字が入った組み合わせだけを調べる。－２を指定できる－） ○検索に使うB列のリスト範囲を指定できる。（いまは、数字が入っているセルまでの個数すべてを組み合わせる数字としているが、たとえばB1：B10までの１０個を調査対象とするなどと指定できる）。 以上です。 無理な場合は読み流していただいて構いません。 早速、改良していただいたコードを試させていただきます。 感想、また書き込みます。
- _Kyle
- ベストアンサー率78% (109/139)
#4=5=6です。 何度もすみません。再々訂正です。 「制限ナシ」用の子プロシージャ SampleF について、 「残りのどれを使っても超えるならアウト」の判定が、 IFの方とSelectCaseの方と２つあります。 IFステートメントの方は不要ですので削除してください。 '----------------------↓ 削除ココカラ ↓---------------------- '残りのどれを使っても超えるならアウト If imAry(imIdx) > imSum Then Exit Sub '----------------------↑ 削除ココマデ ↑---------------------- ※元の状態でも少し遅くなるだけできちんと動作はします。 よくわからなければそのまま残してもかまいません。 ※「制限アリ-反転」SampleF2，「制限アリ-通常」SampleF3については 必要な判定ですのでそのまま残してください。 …ちょっと泣けてきました。
補足
途中で仕様を変更するというのは、自分も低レベルなマクロを 組んでいて、かなり嫌なものです。 要望を出したにもかからわず、仕様を変更し、再アップして くださって、本当に感謝しております。 また、ご丁寧に訂正までしてくださり、お心遣いに感激です。 １週間ほど仕事でネットの使えない環境になりますが、今回の _Kyleさんのプログラムを十分に使わせていただき、感想・要望を またまた書き込みさせていただきます。 結構、いろんなページ・サイトを探したのですが、なかなか今回 のお題に見合うページがなく、困って投稿しました。 たぶん、この質問を参考にされいてる方が多数いらっしゃると 思います。 _Kyleさん、ほんとうにありがとうございます。 では、来週末また書き込みます。
- _Kyle
- ベストアンサー率78% (109/139)
- _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個とする＝ 合計１０を求める場合、○１、９ ○２、３、５ ×１、２、３、４） 合計を求める際の組み合わせるリストの最大個数を、セル入力で、 指定することは可能ですか？
- _Kyle
- ベストアンサー率78% (109/139)
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/17070)
- rukuku
- ベストアンサー率42% (401/933)
お礼
_Kyleさんのおっしゃる通り、当初のテーマとは私自身の発言もずれてきてしまいました。 _Kyleにどっぷりと甘えてしまいました。 どんどん、要望通りにマクロを修正できるスキルの高さに、ついつい興奮して要望を出してしまいました。 今回の回答には、本当に助かりました。ありがとうございます。 あとはマクロを少しずつ勉強して、自分で理解して使わせていただきたいと思います。 最終版も大事に使わせていただいて、わからないところがあればマクロについて質問させていただきます。 本当にありがとうございました。
補足
申し訳ありませんが、オーバーフローをしてしまう場合があるのですが、リストの数字の桁数が多いのでしょうか？ ＞sumAry(i) = sumAry(i) + itmAry(j, 0) の場所で止まってしまいます。 該当の変数のLomg型をもっと大きいものに変えればいいのでしょうか。