[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ランダムな振り方』(ランダム)
こんな事は無理でしょうか
4 A B C D 5 項目 単価 数量 合計 6 abc 10 10 100 7 def 20 - 0 8 ghi 30 - 0 9 jkl 40 3 120 10 abc 50 - 0 11 def 60 2 120 12 ghi 70 - 0 13 jkl 80 - 0 14 abc 90 3 270 15 def 100 - 0 16 ghi 110 3 330 17 jkl 120 - 0 18 abc 130 4 520 19 def 140 - 0 20 ghi 150 4 600 21 jkl 160 - 0 22 abc 170 5 850 23 def 180 - 0 24 ghi 190 5 950 25 jkl 200 - 0 26 abc 210 6 1260 27 def 220 - 0 28 ghi 230 6 1380 29 jkl 240 - 0 30 abc 250 6 1500 合計 8000 ←ここを入れるとC列がランダムに 上記のようにD31に数字をいれるとC列に数字が入る。 C列の条件は最低でも10個の数字を使用・1〜10までの数字を使用です。 (単価は300以下で設定されています) 出来ればマクロ?で処理を・・希望です。 条件ばかり言って申し訳ございません。
回答が付かないようなので上げますが、 ご質問のようなことは、まず無理でしょう。
25のセルから10セルを選ぶ組み合わせは、3,268,760通り、 それぞれが 1〜10の数字を持つ組み合わせは、10*10 で100通り。 つまり全部で 326,876,000通りをしらみつぶしに調べないと いけません。仮に、1秒で1万通りの計算が出来たとしても、 すべて調べるには9時間かかります。まぁ、答えが出たら そこでストップするならもっと早く終わりますが。 さらに「最低でも10個の数字」というからには、 11セル以上も考慮すると、場合の数はもっと大きくなります。
適当に数字をふって(これはマクロで可能)、後は目で見ながら 求める答えになるように調整するのが実用的かな。 (純丸)(o^-')b
回答でなくてすみませんが、 純丸さんも書かれていますが、簡単に解ける問題ではありません。 これは「組合せ最適化問題」としていろいろなやり方が研究されている 分野に該当すると思います。
できなくはありませんが、現在の条件では仕様が十分でありませんし、 実際に実用レベルにするにはある程度VBAやアルゴリズムの素養が必要に なる思います。
蛇足ですが、丸投げの質問は歓迎されないというのもあるかと思います。 (Mook)
>C列がランダムに
ランダムと云うことは、「結果は1通りでいい」と云うことですか?
回答側は、全組合せの算出を前提にしているので、計算量が多過ぎて非現実的と考えていますが、 兎に角「デタラメ風に計算してワンセット出せばいい」と云うのでしたら出来るかもです。。。
・・・にしても、これが何の役に立つのか全く想像つきません (^^ゞ
(半平太)
何でもいいから1セットであれば、だいぶ条件はゆるくなりますが、 解が無い場合はどうするのかなど、不明な点は残ります。
解が無いときには「なるべく誤差が少ない解を出したい」、などとなると またまた問題が複雑になりますね。 (Mook)
>解が無い場合はどうするのかなど、不明な点は残ります。
解がない場合は最悪です。 それだったら「しらみつぶし」の方がまだマシですね(無いと断言できるから)。
ただ「ランダムに取り出したい」と云うことなので、当たりは「ごまんとある」と踏んでいます。
(半平太)
みなさん本当にありがとうございます。 (半平太)さんの 兎に角「デタラメ風に計算してワンセット出せばいい」と云うのでしたら・・・でお願いできないでしょうか。(ランダム)
とにかくこの手の問題は、条件が少し変わると、とたんに大変になります。 今回提示された状態に特化したサンプルです。 (データが昇順、10刻みで10から250までないと正常に動作しません。)
参考になるようであれば、ご自身でカスタマイズしてご利用ください。 ならないようであれば、他の方の回答をお待ちください。
Sub sample() Dim targetSum&, rest&, num&, i& targetSum = Range("D27").Value If Application.WorksheetFunction.Sum(Range("B2:B26")) * 10 < targetSum _ Or Application.WorksheetFunction.Sum(Range("B2:B11")) > targetSum _ Or targetSum Mod 10 <> 0 Then MsgBox "解なし" Exit Sub End If
Range("C2:D26").Value = "" Range("C2:C11").Value = 1 Range("B2:B11").Copy Destination:=Range("D2:D11")
rest = targetSum - Application.WorksheetFunction.Sum(Range("B2:B11")) For i = 26 To 2 Step -1 num = Int(rest / Cells(i, "B")) If num > 10 - Cells(i, "C") Then num = 10 - Cells(i, "C") Cells(i, "C") = num + Cells(i, "C") Cells(i, "D") = Cells(i, "B") * Cells(i, "C") rest = rest - num * Cells(i, "B") If rest = 0 Then Exit Sub Next End Sub (Mook)
面白そうなんで寄せてくらはい。 当然ながら或る一定数字以上、以下でなければ成立しまへん。 ま、ま、試してみまひょ。 D31へ合計数値を入力します。 (弥太郎)
’標準モジュールへ (エラーがでたばやいのイベント復活マクロ) '------------ Sub イベント復元() Application.EnableEvents = True End Sub
'そのシートモジュールへ '------------------------ Option Explicit Option Base 1 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer, Cnt As Integer, a As Long, b As Long, m As Integer Dim t As Integer, n As Integer, x(1 To 25, 1 To 2), y(25), ary, tbl Dim flg As Boolean, totl As Long If Target.Count > 1 Then Exit Sub If Target.Address(0, 0) <> "D31" Then Exit Sub Randomize Range("c6:d30").ClearContents If Target = "" Then Exit Sub Application.EnableEvents = False tbl = Range("a6:d30").Value ReDim ary(1 To 25) m = 25 y(1) = Empty Do While Target <> totl t = t + 1 Do While Cnt <= IIf(t = 1, 10, UBound(tbl, 1)) a = Int(Rnd * m) + 1 a = IIf(t = 1, a, ary(a)) If a = 0 Then Exit Do b = Int(Rnd * 10) + 1 If IsError(Application.Match(a, y, 0)) Then Cnt = Cnt + 1 y(Cnt) = a x(a, 1) = b x(a, 2) = tbl(a, 2) * b totl = totl + x(a, 2) End If If Target < totl Then Cnt = Cnt - 1 y(IIf(Cnt = 0, 1, Cnt)) = Empty totl = totl - x(a, 2) x(a, 1) = Empty x(a, 2) = Empty Exit Do ElseIf Target = totl And Cnt >= 10 Then MsgBox "バンザ〜イ" flg = True Exit Do End If If Cnt >= 25 Then Exit Do Loop If flg Then Exit Do ReDim ary(1 To 25 - Cnt + 1) m = 0 For i = 1 To UBound(tbl, 1) If IsEmpty(x(i, 1)) And tbl(i, 2) <= Target - totl Then m = m + 1 ary(m) = i End If Next i If m <= 1 Then For i = 1 To UBound(tbl, 1) If tbl(i, 2) = Target - totl And IsEmpty(x(i, 1)) Then x(i, 1) = 1 x(i, 2) = tbl(i, 2) Exit Do End If Next i For i = UBound(tbl, 1) To 1 Step -1 If tbl(i, 2) <= Target - totl And x(i, 1) < 10 Then For n = 1 To 10 - x(i, 1) If Target - totl < tbl(i, 2) Then Exit For ElseIf Target - totl = tbl(i, 2) Then x(i, 1) = x(i, 1) + 1 x(i, 2) = x(i, 1) * tbl(i, 2) totl = totl + tbl(i, 2) Exit Do ElseIf Target - totl > tbl(i, 2) Then x(i, 1) = x(i, 1) + 1 x(i, 2) = x(i, 2) + tbl(i, 2) totl = totl + tbl(i, 2) End If Next n End If Next i End If If t > 100 Then MsgBox "正確には抽出でけまへんでした。 もう一回やり直してくらはい": Exit Do Loop Range("c6").Resize(UBound(tbl, 1), 2) = x trbl: Application.EnableEvents = True End Sub
そうそう、データ数が10に満たない(合計額が少ない)ばやいは、再度試してみまひょ う。 尤もこれらを制御するマクロを追加すれば大丈夫でっせ、えぇ。
(Mook)さん(弥太郎)さん本当にありがとうございました。 しかし私の質問(例)が悪かったと反省しています。
C列の条件は最低でも10個の数字を使用・1〜10までの数字を使用です。 (単価は300以下で設定されています)
上記を C列の条件は最低でも10個の数字を使用・1〜30までの数字を使用です。 (単価は1〜10000以下で設定されています) 叱られるとは思い 本当に申し訳ございません。
(D31が567891と入れた場合も対応出来るようになれば)(ランダム)
ソルバーも使えそうに思います。
「D31セルの値を直接読みとって」 なんて事は出来ませんが 最初に地道な設定をすれば 後は、目標値を入力して 実行するだけです。
(HANA)
一昔前に「反省だけなら○○でもする」なんていうコマーシャルがありましたなぁ。^^ それは兎も角1円単位のデータがあるんなら単価の1行目には必ず1円というデータを 挿入しとかなあきまへん。でないと無限ループに陥りまっせぇ。 (弥太郎) '--------------------------- Option Explicit Option Base 1 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer, Cnt As Integer, a As Long, b As Long, m As Integer Dim t As Integer, n As Integer, x(1 To 25, 1 To 2), y(25), ary, tbl Dim flg As Boolean, flg1 As Boolean, totl As Long, f As Integer, d As Integer If Target.Count > 1 Then Exit Sub If Target.Address(0, 0) <> "D31" Then Exit Sub Randomize Range("c6:d30").ClearContents If Target = "" Then Exit Sub Application.EnableEvents = False tbl = Range("a6:d30").Value ReDim ary(1 To 25) m = 25 y(1) = Empty Do While Target <> totl t = t + 1 Do While Cnt <= IIf(t = 1, 10, UBound(tbl, 1)) a = Int(Rnd * m) + 1 a = IIf(t = 1, a, ary(a)) If a = 0 Then Exit Do b = Int(Rnd * 10) + 1 If IsError(Application.Match(a, y, 0)) Then If a < 4 And b = 10 Then b = b - IIf(a = 1, b + 1 - b, 1) End If Cnt = Cnt + 1 y(Cnt) = a x(a, 1) = b x(a, 2) = tbl(a, 2) * b totl = totl + x(a, 2) End If If Target < totl Then Cnt = Cnt - 1 y(IIf(Cnt = 0, 1, Cnt)) = Empty totl = totl - x(a, 2) x(a, 1) = Empty x(a, 2) = Empty Exit Do ElseIf Target = totl And Cnt >= 10 Then MsgBox "バンザ〜イ" flg = True Exit Do End If If Cnt >= 25 Or tbl(UBound(tbl, 1), 2) >= Target - totl Then flg1 = True: Exit Do Loop If flg Then Exit Do ReDim ary(1 To 25 - Cnt + 1) m = 0 For i = 1 To UBound(tbl, 1) If IsEmpty(x(i, 1)) And tbl(i, 2) <= Target - totl Then m = m + 1 ary(m) = i End If Next i If m <= 1 Or flg1 Then For i = 1 To UBound(tbl, 1) If tbl(i, 2) = Target - totl And IsEmpty(x(i, 1)) Then x(i, 1) = 1 x(i, 2) = tbl(i, 2) Cnt = Cnt + 1 Call work(Cnt, tbl, x, Target) End If Next i Do While Target <> totl d = d + 1 a = Int(Rnd * 24) + 2 b = Int(Rnd * (10 - x(a, 1))) + 1 If Target - totl <= tbl(2, 2) - tbl(1, 2) Then x(1, 1) = x(1, 1) + (Target - totl) / tbl(1, 2) x(1, 2) = x(1, 1) * tbl(1, 2) totl = totl + Target - totl Call work(Cnt, tbl, x, Target) End If
If tbl(a, 2) <= Target - totl And x(a, 1) < 10 Then For n = 1 To 10 - x(a, 1) If Target - totl < tbl(a, 2) Then Exit For ElseIf Target - totl = tbl(a, 2) Then x(a, 1) = x(a, 1) + 1 x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) Call work(Cnt, tbl, x, Target) Else If x(a, 1) < 10 Then If Target - totl > tbl(a, 2) * b Then x(a, 1) = x(a, 1) + b x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) * b
ElseIf Target - totl = tbl(a, 2) * b Then x(a, 1) = x(a, 1) + b x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) * b Call work(Cnt, tbl, x, Target) Else For f = 1 To b If Target - totl > tbl(a, 2) Then x(a, 1) = x(a, 1) + 1 x(a, 2) = x(a, 2) + tbl(a, 2) totl = totl + tbl(a, 2) If totl = Target Then Call work(Cnt, tbl, x, Target) End If End If Next f End If
End If End If Next n End If If d >= 100 Then MsgBox "ん? データがおかしいんとちゃいまっか! " & Chr(10) & _ "それともエクセルのバグかしら?^^ やり直してんか" Application.EnableEvents = True End End If Loop End If Loop Range("c6").Resize(UBound(tbl, 1), 2) = x trbl: Application.EnableEvents = True End Sub Sub work(Cnt, tbl, x, Target) If x(1, 1) > 10 Then Cnt = 1 If Cnt < 10 Then Range("c6:d30").Clear Application.EnableEvents = True Target = Target.Value Else Range("c6").Resize(UBound(tbl, 1), 2) = x Application.EnableEvents = True End End If
End Sub
弥太郎さん、えらいなぁ。
質問者さんは、回答されたものを理解しようとしてますか? (Mook)
>弥太郎さん、えらいなぁ。 最大級の賛辞おおきに〜。 I Love You チュッ ケホ ケホ ^^ (弥太郎)
本当にありがとうございます。 しかし、B列の単価が悪いのか?
データがおかしいんとちゃいまっか! それともエクセルのバグかしら?^^ やり直してんか" のメッセージが出てしまいます。 B列のB6〜B30はどのような単価を入れたらよいのでしょうか?
C列の条件は最低でも10個の数字を使用・1〜30までの数字を使用です。 ↑この条件が原因でしょうか? D31が1だとしたらダメですよね・・・何度ももうしわけございません。(ランダム)
今更説明する必要はないんでせうが、=sum(b6:b30)*10 以上の数値は不成立になります し、それに近い数値もランダムで拾い出す関係上なかなかエクセルのバグから逃れる事 はでけまへん。また=sum(b6:b15)以下の数値も不成立ですし、それに近い数値も上記同 様うまく拾い出す事はでけまへん。
>D31が1だとしたらダメですよね・ こんな事までご説明申し上げなければなりまへんか?
あんさんが最初に呈示されたデータでD31に数値を打ち込んだらどうでした?ちゃんと 拾い出しましたやろ? 今度はB6に1を書き込んで端数を含むデータをD31に書き込みます。 ランダムに拾い出してその残りが20以下になったばやいは当然乍ら何年検索してもC列の データが10と制限されている以上得たいデータは出てきまへんわなぁ。 そうした時はMsgBoxでもう一度(100回検索して時点で)D31に同じ数値を打ち込んで新た にやり直す方法しかないんですわ。10回もやり直してダメやったらデータ(B列かD31 のデータに不備が有ると考えられます。 その時はCtrl+Breakでマクロを中断して「イベント復活」を走らせB列或いはD31のデー タを変更する方が近道でんなぁ。
ハッキリしているのはB6とB7に入るデータが極端な差が有れば有るほどMsgBoxの出る頻 度は高くなります、ハイ。 もしこれを解消したいなら、C6に抽出するでーたは10以上でもOKとするしか無いでせう なぁ。
話は元に戻しまして、あんさんの初めのデータ(B6が10)で実行したばやい、まぁ希有な 現象なんでせうが B C 10 10 20 10 30 10 40 10 50 10 60 10 70 3 80 1 . . . . . . といった塩梅に並んでしまったとしまへんか。 D31のデータまで残数60以下となってしまったら、これはもう無限ループに陥ります。 それを回避するためにB6からB8のデータは仮にランダムに拾い出す数値が10で有っても それを下回る数値を設定してあります。 つまりC6からC8迄は9となります。 従って残りが60以下になってもその3データで賄えるよう細工してあります。 ですから厳密にいえば完全なランダムでは無いっちゅう事ですのでご留意くらはい。
こうした諸々の事情を踏まえた上で検証してみておくんなはれ。 (弥太郎)
なんか雲行きがおかしいですね。
>D31が567891と入れた場合も対応出来るようになれば ランダムさんは、「必ず対応出来る」方法があると勘違いされていませんか?
対応できるかどうかは、目標値のみならず各単価の組合せで「相対的に決まる」ものです。
以下は当たり前のことですが、書いて置きます。 1.成立する組合せがなければ、絶対にヒットしません。 2.成立する組み合わせが1つしかなければ、ランダムに選ぶことはできません。 3.成立する組み合わせが僅かしかなければ、「デタラメ風計算方式」(以下、交通事故方式と称す)で、 探し出せる確率は非常に低いです。
交通事故方式の対応が有効に働くのは、成立する組み合わせが沢山ある場合だけです。
もし各単価と目標値の関係が、上記1〜3の状態なら「しらみつぶし方式」でしか対応できません。 その方式なら、「1.ない」「2.ひとつある」「3.ランダムに決定した」と断言できます。 しかし、交通事故方式では、まったく予測がつきません。
もっとも、しらみつぶし方式でも理論的に結論にたどり着けると云うだけで、 実際には、計算量が膨大なため「いつ果てるとも分からない」とほとんど同義です。
>B列の単価が悪いのか? >B列のB6〜B30はどのような単価を入れたらよいのでしょうか? 単価に良し悪しはありません。 単価は前提条件なのですから、人と相談して決めるような性格のものではありません。 (そこまで、変えてよければ、ご質問のもともとの意味が何なのかサッパリ分からなくなります)
うまく算出できなかった「各単価と目標値」を掲示して頂けませんか? (もう、単なるサンブルデータで論じていられる段階ではありません)
それで、もう少し具体的な説明が回答側から寄せられると思います。
(半平太)
ほんなら、これでどや、んんちくしょう!^^ 勿論B6には1が必要ですし、処理でける範囲内(↑で説明済み)の数値でなければなら ない条件が同様です。 (弥太郎) '-------------------------------------- Option Explicit Option Base 1 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer, Cnt As Integer, a As Long, b As Long, m As Integer Dim t As Integer, n As Integer, u As Integer, x(1 To 25, 1 To 2), y(25), ary, tbl Dim flg As Boolean, flg1 As Boolean, totl As Long, f As Integer, d As Integer If Target.Count > 1 Then Exit Sub If Target.Address(0, 0) <> "D31" Then Exit Sub Randomize Range("c6:d30").ClearContents If Target = "" Then Exit Sub Application.EnableEvents = False tbl = Range("a6:d30").Value ReDim ary(1 To 25) m = 25 Do While Target <> totl t = t + 1 Do While Cnt <= IIf(t = 1, 10, UBound(tbl, 1)) a = Int(Rnd * m) + 1 a = IIf(t = 1, a, ary(a)) If a = 0 Then Exit Do b = Int(Rnd * 30) + 1 If IsError(Application.Match(a, y, 0)) Then b = IIf(a = 1 And b > 15, 15, b) b = IIf(a = 2 Or a = 3 And b > 25, 25, b) Cnt = Cnt + 1 y(Cnt) = a x(a, 1) = b x(a, 2) = tbl(a, 2) * b totl = totl + x(a, 2) End If If Target < totl Then Cnt = Cnt - 1 y(IIf(Cnt = 0, 1, Cnt)) = Empty totl = totl - x(a, 2)
x(a, 1) = Empty x(a, 2) = Empty Exit Do ElseIf Target = totl And Cnt >= 10 Then MsgBox "バンザ〜イ" flg = True Exit Do End If If Cnt >= 25 Or tbl(UBound(tbl, 1), 2) >= Target - totl Then flg1 = True: Exit Do Loop If flg Then Exit Do ReDim ary(1 To 25 - Cnt + 1) m = 0 For i = 1 To UBound(tbl, 1) If IsEmpty(x(i, 1)) And tbl(i, 2) <= Target - totl Then m = m + 1 ary(m) = i End If Next i If m <= 1 Or flg1 Then For i = 1 To UBound(tbl, 1) If tbl(UBound(tbl, 1), 2) < Target - totl Then Exit For If tbl(i, 2) = Target - totl And IsEmpty(x(i, 1)) Then x(i, 1) = 1 x(i, 2) = tbl(i, 2) Cnt = Cnt + 1 Call work(Cnt, tbl, x, Target) End If Next i Do While Target <> totl d = d + 1 a = Int(Rnd * 24) + 2 b = Int(Rnd * (30 - x(a, 1))) + 1 If Target - totl < tbl(UBound(tbl, 1), 2) Then For i = UBound(tbl, 1) To 1 Step -1 If Target - totl >= tbl(i, 2) Then If x(i, 1) < 30 Then For u = 1 To (Target - totl) \ tbl(i, 2) x(i, 1) = x(i, 1) + 1 x(i, 2) = x(i, 1) * tbl(i, 2) totl = totl + tbl(i, 2) If Target = totl And x(i, 1) <= 30 Then Call work(Cnt, tbl, x, Target) Else Range("c6:d30").Clear Application.EnableEvents = True Target = Target.Value End If Next u End If End If Next i End If
If Target - totl <= tbl(2, 2) - tbl(1, 2) Then x(1, 1) = x(1, 1) + (Target - totl) / tbl(1, 2) x(1, 2) = x(1, 1) * tbl(1, 2) totl = totl + Target - totl Call work(Cnt, tbl, x, Target) End If If tbl(1, 2) <= Target - totl And x(a, 1) < 30 Then For n = 1 To 30 - x(a, 1) If Target - totl < tbl(a, 2) Then Exit For ElseIf Target - totl = tbl(a, 2) Then x(a, 1) = x(a, 1) + 1 x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) Call work(Cnt, tbl, x, Target) Else If x(a, 1) < 30 Then If Target - totl = tbl(a, 2) * b Then x(a, 1) = x(a, 1) + b x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) * b Call work(Cnt, tbl, x, Target) ElseIf Target - totl > tbl(a, 2) * b Then x(a, 1) = x(a, 1) + b x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) * b Exit For Else For f = 1 To b If Target - totl > tbl(a, 2) Then x(a, 1) = x(a, 1) + 1 x(a, 2) = x(a, 1) * tbl(a, 2) totl = totl + tbl(a, 2) If totl = Target Then Call work(Cnt, tbl, x, Target) End If End If If Target - totl < tbl(a, 2) Then Exit For Next f End If
End If End If Next n End If If d >= 200 Then MsgBox "ん? データがおかしいんとちゃいまっか! " & Chr(10) & _ "それともエクセルのバグかしら?^^ やり直してんか" Application.EnableEvents = True End End If Loop End If Loop Range("c6").Resize(UBound(tbl, 1), 2) = x trbl: Application.EnableEvents = True End Sub
Sub work(Cnt, tbl, x, Target) If Cnt < 10 Then Range("c6:d30").Clear Application.EnableEvents = True Target = Target.Value Else Range("c6").Resize(UBound(tbl, 1), 2) = x Application.EnableEvents = True End End If
End Sub
検証用の不要コードを削除しました。 (弥太郎) 11/16 21:36 勝手に変更されるから、エライ目ぇにおうた。プリプリ
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.