[[20081112211632]] 『ランダムな振り方』(ランダム) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『ランダムな振り方』(ランダム)
 こんな事は無理でしょうか

 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.