FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その8 


副題「足して100になるような乱数のアルゴリズム」

質問の内容はこんな感じでした・・・

Excel で、合計値が100となるように、30行使って、0~4の値を割振りたい
http://oshiete1.watch.impress.co.jp/qa4035587.html
に同じようなものがあったけど、VBA じゃないのでわからない

その参照先の方法は、チョッと使えないんじゃないかな・・・ ってんで回答したわけですが・・・
(回答したそのものは後述)

参照先のものを解釈した内容を以下図にまとめてみました。

kEnt185A.jpg

合計値は100、30行、0~4を乱数で・・・
まず気になるのは、30行全部をなめて、都度 0~4 を設定していったとして
・合計値が100に届かなかったら・・・
・途中で合計値が100を超えてしまったら、残りは0・・・
・30行全部に設定してみて、合計が100でなかったら1からやり直し・・・・
 何回やりなおせばいいんだろう・・・ こっちの方が心配・・・

ということで、初めに考えついたのは
・30行全部をなめるんじゃなく、設定する行を乱数で求めて・・・ (設定の偏りをなくしたいかな)
・乱数で 1~4 を求めて・・・(設定行を選んだ=値を設定する・・・なら、0は除外しても)
・設定した値を合計値から引いておいて、その合計値が 0 になったら終わり・・・
これだと、選択しなかった行は 0 のまま・・・

値を設定する際に同じ行が選ばれる事もあるので、以前に設定した値と新値を加算
加算した結果 ≧ 4 なら 4 に・・・ (この方法が良いのかは??)
設定する値は 1~4 範囲を乱数で求めますが、加算すると最大値(4)になりやすいのかなぁ・・・

という事で、違う方法も・・・
設定する行を乱数で求めるのは同じですが、都度 1を加算していくもの
・既に最大値(4)なら何もしない
1加算したら、合計値から1減算して 0 になったら終わり・・・

合計値は100、30行、0~4を乱数で・・・程度なら、この方法もありですかね
行を求める・・・ 1~30 の乱数を 100回・・・・
偏った乱数でなければ、1~30の出現頻度は平均化されるんじゃなかろうか・・・
ある行が突出する・・・・ 結構あるのかな??
最大値(4)へは、すぐに到達するからいいのかな・・・
もし、最大値(25)とかなら、25になる行はあるのだろうか・・・

上記の方法以外にも何個かやってみた。

※ 結果を先に言っておくと、乱数でどうのこうの・・・・
 その乱数をどう扱うかによって、求めたいものが違ってくる・・・
 どの様な傾向をもつものにする・・・等々、考え方・処理の記述次第
乱数で求めているので平等?です・・・・ って、安易に言えるものだろうか・・・

今回のサンプルファイルは Excel になります。

用意したシートは「回答確認用」「NumSum確認用」「NumSum2確認用」の3つです

kEnt185_1.jpg  kEnt185_2.jpg  kEnt185_3.jpg

結果確認は、各シートの「大仏さんの絵」をクリックする事で、
求めた結果一覧が左側に表示されます。

シート「NumSum確認用」「NumSum2確認用」では、上記に加え
・合計値、行数、最大値を自由に設定でき
・求めた結果一覧の下に、検証用の SUM 埋め込み
また、出現数の確認用に
・0~最大値までの数字一覧と
・その右には COUNTIF を埋め込んで、結果一覧での各個数を・・・
・その表が正しいのか下側に SUMPRODUCT を埋め込んで、合計値を求め直しています
 
じゃ、まず回答した内容から・・・

おもしろそうだったのでやってみました。

やってみたのは3パターン
・「test1」
 乱数でどこに、乱数で何(値 1 ~ 4)を、を求めて
 値を設定しないところは 0 のまま
・「test2」
 乱数でどこに、を求めて 1 を加算していく
 最悪無限ループに陥るかも
・「test3」
 test2 の改良バージョン

傾向としては、
test1 は、最大値がでやすい?(乱数でどこ・・・が同じなら加算していたので)
test2 / test3 は平均されやすい?(乱数の発生頻度と同じ?)

0 の出現は、 test2 / test3 では少ない様な気がします。
(乱数なので、そういうものとしても良いのかも)

While 内の実行回数の少ない順(変数 k の値)は、
 test1(100回以下) < test3(100回) < test2(100回以上)
の様な感じ(雰囲気で)

説明は省いても良いですかね

確かめられるのであれば、
  Const CNUMSUM As Long = 100 ' 合計値
  Const CROWMAX As Long = 30 ' 行数
  Const CNUMMAX As Long = 4  ' 最大値
の値を変更して、
 CROWMAX * CNUMMAX > CNUMSUM になっていればソコソコ動くと思います。

Public Sub test1()
  Const CNUMSUM As Long = 100
  Const CROWMAX As Long = 30
  Const CNUMMAX As Long = 4
  Dim iAry(1 To CROWMAX) As Long
  Dim i As Long, k As Long
  Dim iNum As Long, iR As Long

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
  Next

  k = 0
  iNum = CNUMSUM
  While (iNum > 0)
    k = k + 1
    i = Int(CROWMAX * Rnd()) + 1
    iR = Int(CNUMMAX * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    iNum = iNum - iR
  Wend
  Debug.Print "k = " & k

  Range("A1").Resize(CROWMAX) = _
      WorksheetFunction.Transpose(iAry)
End Sub

Public Sub test2()
  Const CNUMSUM As Long = 100
  Const CROWMAX As Long = 30
  Const CNUMMAX As Long = 4
  Dim iAry(1 To CROWMAX) As Long
  Dim i As Long, k As Long
  Dim iNum As Long

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
  Next

  k = 0
  iNum = CNUMSUM
  While (iNum > 0)
    k = k + 1
    i = Int(CROWMAX * Rnd()) + 1
    If (iAry(i) < CNUMMAX) Then
      iAry(i) = iAry(i) + 1
      iNum = iNum - 1
    End If
  Wend
  Debug.Print "k = " & k

  Range("B1").Resize(CROWMAX) = _
      WorksheetFunction.Transpose(iAry)
End Sub

Public Sub test3()
  Const CNUMSUM As Long = 100
  Const CROWMAX As Long = 30
  Const CNUMMAX As Long = 4
  Dim iAry(1 To CROWMAX) As Long, iPos(1 To CROWMAX) As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iHdn As Long

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdn = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iAry(i) = iAry(i) + 1
    If (iAry(i) >= CNUMMAX) Then
      iPos(j) = iPos(CROWMAX - iHdn)
      iHdn = iHdn + 1
    End If
    iNum = iNum - 1
  Wend
  Debug.Print "k = " & k

  Range("C1").Resize(CROWMAX) = _
      WorksheetFunction.Transpose(iAry)
End Sub


この回答・・・ 実は「test1」も、最悪無限ループになる恐れがあります・・・
「test2」→「test3」に施した方法を「test1」に組み込む必要がありますよ・・・・
とは、理解してもらえないんでしょうね・・・

「test2」→「test3」に施した方法・・・ iPos という配列を介入させた・・・
この iPos の役目は以下の様な感じになります。

kEnt185B.jpg

iPos 配列の介入により「test1」を書き換えてみると以下の様にでもなるんでしょうか・・・
Private Sub test4()
  Const CNUMSUM As Long = 100
  Const CROWMAX As Long = 30
  Const CNUMMAX As Long = 4
  Dim iAry(1 To CROWMAX) As Long, iPos(1 To CROWMAX) As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iR As Long, iHdn As Long

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdn = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iR = Int(CNUMMAX * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    If (iAry(i) >= CNUMMAX) Then
      iPos(j) = iPos(CROWMAX - iHdn)
      iHdn = iHdn + 1
    End If
    iNum = iNum - iR
  Wend
  Debug.Print "k = " & k

  Range("D1").Resize(CROWMAX) = _
      WorksheetFunction.Transpose(iAry)
End Sub

 
で、この「test1」~「test4」をまとめて実行する様にしたものが
Public Sub ans()
  Call test1
  Call test2
  Call test3
  Call test4
End Sub

として、シート「回答確認用」の大仏さんをクリックすると結果が一覧表示されます。
何回 While ループしているかは、イミディエイトウィンドウを表示してわかるものになります。

kEnt185_1.jpg


合計値、行数、最大値・・・・ これ変更してチョコチョコと確認したいな・・・
何回 While ループしたのかもシート上で見たいな・・・・
ってんで、シート「NumSum確認用」を作成しました。
「test1」~「test4」で Const 宣言していたものは、関数の引数(パラメータ)として渡すように
それに伴って、配列の確保を ReDim 化して・・・
「test4」を例に書き換えた「test14」は以下の様になりました
Private Sub test14(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iR As Long, iHdn As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdn = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iR = Int(CNUMMAX * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    If (iAry(i) >= CNUMMAX) Then
      iPos(j) = iPos(CROWMAX - iHdn)
      iHdn = iHdn + 1
    End If
    iNum = iNum - iR
  Wend

  With Range(sPos)
    .Offset(-1) = k & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

 
さほど記述は変わっていませんね

これら変更した「test11」~「test14」を起動する様に、関数「NumSum」を以下の様に記述
Public Sub NumSum()
  Dim i As Long, j As Long, k As Long
  Dim iRow As Long

  i = Range("B1"): j = Range("D1"): k = Range("F1")
  If ((i <= 0) Or (j <= 0) Or (k <= 0) Or (i > j * k)) Then Exit Sub
  iRow = Cells.SpecialCells(xlCellTypeLastCell).Row
  If (iRow > 3) Then Range("A4", "A" & iRow).EntireRow.Delete
  Call test11("A4", i, j, k)
  Call test12("B4", i, j, k)
  Call test13("C4", i, j, k)
  Call test14("D4", i, j, k)
  iRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("A" & iRow + 1).Resize(, 4).FormulaR1C1 = "=SUM(R4C:R[-1]C)"

  i = 0
  While (i <= k)
    Cells(i + 4, 6) = i
    i = i + 1
  Wend
  With Range("G4")
    .Resize(k + 1, 4).FormulaR1C1 = "=COUNTIF(R4C[-6]:R" & iRow & "C[-6],RC6)"
    .Offset(k + 1).Resize(, 4).FormulaR1C1 = "=SUMPRODUCT(R4C6:R[-1]C6*R4C:R[-1]C)"
  End With
End Sub

 
実行してみると

kEnt185_2.jpg  kEnt185_2_10.jpg  kEnt185_2_25.jpg

・求めた結果一覧の下に、検証用の SUM 埋め込み
・0~最大値までの数字一覧と
・その右には COUNTIF を埋め込んで、結果一覧での各個数を・・・
・その表が正しいのか下側に SUMPRODUCT を埋め込んで、合計値を求め直しています

これで、当初の目的、合計=100、30行、最大=4の確認は容易にできるようになりました
けど・・・ けど・・・
最大値を10、25とか、合計=500、30行、最大=29とか・・・・チョコチョコいじってると・・・
偏りが・・・・ ありすぎ???
「test11」「test14」では、最大値や0が出やすい?
「test12」「test13」では、突出する部分が少ない?? 平均化されやすい??

合計=500、30行、最大=29 でやってみたのは以下の様な結果になりました。
「test12」「test13」は、中ほどにかたまっているだけですね・・・
もちろん、実行するたびに結果は変わってきます・・・ が、傾向はわかるんじゃないでしょうか?

kEnt185_2_500_29.jpg


じゃ、やり方を変えてみますか・・・
ここからは、シート「NumSum2確認用」のものになっていきます。

「test21」では、まず (合計 \ 行数) + 1 の値を各行に割り振っておきましょうか・・・
半端な部分も合わせて、合計値全部を行に埋めておきましょう・・・
その後で、行2つを任意に抽出して、その2つの行が持つ値を再設定してみますか・・・

例えば、合計=100、30行・・・なら (100 \ 30) + 1 = 4
この 4 を 30行に割当・・・ 25行に4、残り5行は0のまま(設定する行は乱数で求めておく)
で、行2つを任意に選んで、その行の値の中で再設定・・・
この再設定を何回やるか・・・ 0~99回を乱数で求めて・・・・
記述してみたのが以下
Private Sub test21(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iHdn As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  iNum = CNUMSUM
  k = CNUMSUM \ CROWMAX + 1
  If (k > CNUMMAX) Then k = CNUMMAX
  iHdn = 0
  While (iNum > 0)
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iAry(i) = k
    If (iNum < k) Then iAry(i) = iNum
    iNum = iNum - iAry(i)
    iPos(j) = iPos(CROWMAX - iHdn)
    iHdn = iHdn + 1
  Wend

  For k = 1 To Int(100 * Rnd())
    i = Int(CROWMAX * Rnd()) + 1
    j = Int(CROWMAX * Rnd()) + 1
    If (i <> j) Then Call myChange1(iAry(i), iAry(j), CNUMMAX)
  Next

  With Range(sPos)
    .Offset(-1) = k - 1 & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

 
入れ替えする関数部分は
Private Sub myChange1(i1 As Long, i2 As Long, iMax As Long)
  Dim i As Long, j As Long

  i = i1 + i2
  If ((i = 0) Or (iMax * 2 = i)) Then Exit Sub
  j = Int((i + 1) * Rnd())
  If (j > iMax) Then j = iMax
  i = i - j
  If (i > iMax) Then
    j = j + i - iMax
    i = iMax
  End If
  If (i1 = i) Then
    i1 = j
    i2 = i
  Else
    i1 = i
    i2 = j
  End If
End Sub

 
で、また違う処理パターンも考えてみた
先に平均化した値を合計分設定するのは同じですが、入れ替える部分を変更してみた
Private Sub test22(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iHdn As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  iNum = CNUMSUM
  k = CNUMSUM \ CROWMAX + 1
  If (k > CNUMMAX) Then k = CNUMMAX
  iHdn = 0
  While (iNum > 0)
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iAry(i) = k
    If (iNum < k) Then iAry(i) = iNum
    iNum = iNum - iAry(i)
    iPos(j) = iPos(CROWMAX - iHdn)
    iHdn = iHdn + 1
  Wend

  For k = 1 To Int(100 * Rnd())
    For i = 1 To CROWMAX - 1
      Call myChange1(iAry(i), iAry(i + 1), CNUMMAX)
    Next

  Next

  With Range(sPos)
    .Offset(-1) = k - 1 & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

ここでは、隣りの行と値を見直していく・・・ っというものになりました。

じゃ、2つの行を任意に選ぶのは「test21」と同じだが、値の設定の仕方を変えてみますか・・・
「test23」では行間の値増減は、±1
Private Sub myChange2(i1 As Long, i2 As Long, iMax As Long)
  Dim i As Long

  i = i1 + i2
  If ((i = 0) Or (iMax * 2 = i)) Then Exit Sub
  If ((i1 = iMax) Or (i2 = 0)) Then
    i1 = i1 - 1
    i2 = i2 + 1
  Else
    i1 = i1 + 1
    i2 = i2 - 1
  End If
End Sub

 

じゃ~じゃ~でもう1つ
「test21」で初期の値を行に割り振った時、最後に設定した行を使い回ししていきますか・・・
つまり、0~99回を乱数で求めて・・・・ってした時に、必ず値が埋まっていた?ところを指定する様に・・・
Private Sub test24(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iHdn As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  iNum = CNUMSUM
  k = CNUMMAX
  iHdn = 0
  While (iNum > 0)
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iAry(i) = k
    If (iNum < k) Then iAry(i) = iNum
    iNum = iNum - iAry(i)
    iPos(j) = iPos(CROWMAX - iHdn)
    iHdn = iHdn + 1
  Wend

  For k = 1 To Int(100 * Rnd())
    j = Int(CROWMAX * Rnd()) + 1
    If (i <> j) Then Call myChange1(iAry(i), iAry(j), CNUMMAX)
    i = j
  Next

  With Range(sPos)
    .Offset(-1) = k - 1 & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

 
これらを実行するシート「NumSum2確認用」の関数は、NumSum 同様の構成に
Public Sub NumSum2()
  Dim i As Long, j As Long, k As Long
  Dim iRow As Long

  i = Range("B1"): j = Range("D1"): k = Range("F1")
  If ((i <= 0) Or (j <= 0) Or (k <= 0) Or (i > j * k)) Then Exit Sub
  iRow = Cells.SpecialCells(xlCellTypeLastCell).Row
  If (iRow > 3) Then Range("A4", "A" & iRow).EntireRow.Delete
  Call test21("A4", i, j, k)
  Call test22("B4", i, j, k)
  Call test23("C4", i, j, k)
  Call test24("D4", i, j, k)
  iRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("A" & iRow + 1).Resize(, 4).FormulaR1C1 = "=SUM(R4C:R[-1]C)"

  i = 0
  While (i <= k)
    Cells(i + 4, 6) = i
    i = i + 1
  Wend
  With Range("G4")
    .Resize(k + 1, 4).FormulaR1C1 = "=COUNTIF(R4C[-6]:R" & iRow & "C[-6],RC6)"
    .Offset(k + 1).Resize(, 4).FormulaR1C1 = "=SUMPRODUCT(R4C6:R[-1]C6*R4C:R[-1]C)"
  End With
End Sub

 
ここで表示される回数は、シート「NumSum確認用」とは違い、何回入れ替え処理をしたか・・・になります。
やってみると、このシート「NumSum2確認用」のものは使えそうもないのかな・・・

kEnt185_3.jpg  kEnt185_3_10.jpg  kEnt185_3_25.jpg


※ サンプルファイルにあるのはここまでのものになります。
  以下のものはサンプルにはありませんが、転記してやってみれば動くと思います。

さぁ~てっと、
私はあきらめが悪いので、サンプルファイルを作った後もいろいろとやってみてました。
「test11」その最大値になったものは除外していく改良版「test14」これをベースに考えてました・・・
・同じ行が選ばれたら加算して・・・ それゆえに最大値が出やすくなっていた??
・他に比べると0の出現頻度が多い??

であれば、同じ行が簡単に選ばれない様にして、多くの行を対象にするようにすれば・・・・・・
・加算で最大値になりにくくなるし
・多くの行に値を設定できるので、0の行は減少するかも・・・

標準モジュール「Module2」の記述「test11」~「NumSum」までを
「Module4」へ丸々コピーして・・・・ (というより、以下をコピーすれば用は足りますけど・・・)
Private Sub test31(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long, m As Long
  Dim iNum As Long, iR As Long
  Dim iHdnMax As Long, iHdn As Long, iHdnEver As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdnMax = CROWMAX - (CNUMSUM \ CNUMMAX)
  If (iHdnMax < 0) Then iHdnMax = 0
  iHdn = 0
  iHdnEver = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    For m = j To CROWMAX - iHdnEver - 1
      iPos(m) = iPos(m + 1)
    Next
    iPos(CROWMAX - iHdnEver) = i
    If (iHdn < iHdnMax) Then iHdn = iHdn + 1
    iR = Int(CNUMMAX * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    If (iAry(i) >= CNUMMAX) Then
      iHdnEver = iHdnEver + 1
      If (iHdn < iHdnEver) Then iHdn = iHdnEver
    End If
    iNum = iNum - iR
  Wend

  With Range(sPos)
    .Offset(-1) = k & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

Private Sub test32(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long, m As Long
  Dim iNum As Long, iR As Long
  Dim iHdnMax As Long, iHdn As Long, iHdnEver As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdnMax = CROWMAX - (CNUMSUM \ CNUMMAX)
  If (iHdnMax < 0) Then iHdnMax = 0
  iHdn = 0
  iHdnEver = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    For m = j To CROWMAX - iHdnEver - 1
      iPos(m) = iPos(m + 1)
    Next
    iPos(CROWMAX - iHdnEver) = i
    If (iHdn < iHdnMax) Then iHdn = iHdn + 1
    iR = Int(CNUMMAX * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    If (iAry(i) >= CNUMMAX) Then
      iHdnEver = iHdnEver + 1
      If (iHdn < iHdnEver) Then iHdn = iHdnEver
      If ((CROWMAX - iHdnMax) > 5) Then iHdnMax = iHdnMax + 1
    End If
    iNum = iNum - iR
  Wend

  With Range(sPos)
    .Offset(-1) = k & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

Private Sub test33(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long, m As Long
  Dim iNum As Long, iR As Long
  Dim iHdnMax As Long, iHdn As Long, iHdnEver As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdnMax = CROWMAX - (CNUMSUM \ CNUMMAX)
  If (iHdnMax < 0) Then iHdnMax = 0
  iHdn = 0
  iHdnEver = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    For m = j To CROWMAX - iHdnEver - 1
      iPos(m) = iPos(m + 1)
    Next
    iPos(CROWMAX - iHdnEver) = i
    If (iHdn < iHdnMax) Then iHdn = iHdn + 1
    iR = Int((Int(CNUMMAX * Rnd()) + 1) * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    If (iAry(i) >= CNUMMAX) Then
      iHdnEver = iHdnEver + 1
      If (iHdn < iHdnEver) Then iHdn = iHdnEver
      If ((CROWMAX - iHdnMax) > 5) Then iHdnMax = iHdnMax + 1
    End If
    iNum = iNum - iR
  Wend

  With Range(sPos)
    .Offset(-1) = k & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

Private Sub test14(sPos As String, CNUMSUM As Long, CROWMAX As Long, CNUMMAX As Long)
  Dim iAry() As Long, iPos() As Long
  Dim i As Long, j As Long, k As Long
  Dim iNum As Long, iR As Long, iHdn As Long

  ReDim iAry(1 To CROWMAX)
  ReDim iPos(1 To CROWMAX)

  Randomize
  For i = 1 To CROWMAX
    iAry(i) = 0
    iPos(i) = i
  Next

  k = 0
  iNum = CNUMSUM
  iHdn = 0
  While (iNum > 0)
    k = k + 1
    j = Int((CROWMAX - iHdn) * Rnd()) + 1
    i = iPos(j)
    iR = Int(CNUMMAX * Rnd()) + 1
    If (iAry(i) + iR > CNUMMAX) Then iR = CNUMMAX - iAry(i)
    If (iR > iNum) Then iR = iNum
    iAry(i) = iAry(i) + iR
    If (iAry(i) >= CNUMMAX) Then
      iPos(j) = iPos(CROWMAX - iHdn)
      iHdn = iHdn + 1
    End If
    iNum = iNum - iR
  Wend

  With Range(sPos)
    .Offset(-1) = k & " 回"
    .Resize(CROWMAX) = WorksheetFunction.Transpose(iAry)
  End With
End Sub

Public Sub NumSum3()
  Dim i As Long, j As Long, k As Long
  Dim iRow As Long

  i = Range("B1"): j = Range("D1"): k = Range("F1")
  If ((i <= 0) Or (j <= 0) Or (k <= 0) Or (i > j * k)) Then Exit Sub
  iRow = Cells.SpecialCells(xlCellTypeLastCell).Row
  If (iRow > 3) Then Range("A4", "A" & iRow).EntireRow.Delete
  Call test31("A4", i, j, k)
  Call test32("B4", i, j, k)
  Call test33("C4", i, j, k)
  Call test14("D4", i, j, k)
  iRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("A" & iRow + 1).Resize(, 4).FormulaR1C1 = "=SUM(R4C:R[-1]C)"

  i = 0
  While (i <= k)
    Cells(i + 4, 6) = i
    i = i + 1
  Wend
  With Range("G4")
    .Resize(k + 1, 4).FormulaR1C1 = "=COUNTIF(R4C[-6]:R" & iRow & "C[-6],RC6)"
    .Offset(k + 1).Resize(, 4).FormulaR1C1 = "=SUMPRODUCT(R4C6:R[-1]C6*R4C:R[-1]C)"
  End With
End Sub

 
「test31」の考え方は、iPos の扱いについて以下の様な扱いになります。

kEnt185C.jpg

で、この中で iHdnMax をどこに設定しようか・・・
  行数 - (合計値 \ 最大値)
でやってみますか・・・
合計値=100、行数=30、最大値=4 なら、 30 - (100 \ 4) = 5
合計値=100、行数=30、最大値=10 なら、 30 - (100 \ 10) = 20
合計値=100、行数=30、最大値=20 なら、 30 - (100 \ 20) = 25
最大値が多く出現しそうなら、行の再選択で遅延させる部分は少なくても良いか・・・
もっと良い求め方・算出・・・系数があるのかも??
ただね・・・
上記での最大値=20とか大きくなっていくにつれて、遅延させる行数が増えていきますが
そこに到達する前に、合計値が求まる事が多く?なります。
つまり、加算処理をしないうちに求まっちゃった・・・ ってなことになりがちの様な気が・・・


「test32」の考え方は、上記をチョッと改良して

kEnt185D.jpg

最大値になったものが出てきたら、iHdnMax を引き上げていきますが、
最低でも5行は残しておきますか・・・
何個か残しておかないと、0が出現しなくなるのかなぁ~~


「test33」の考え方は、「test32」を使った時、
加算する状況になっても、結果最大値になる確率を下げる??・・・
つまり、設定値を求める時に、最大値から乱数で求め・・・さらに乱数で設定値を求める2段階に・・・
これらでやってみた結果は以下の様になりました。
(合計=500、30行、最大=29)

kEnt185_w_500_29.jpg


いろいろやってみて、自分なりに使えそうなのは・・・「test33」でしょうか・・・
ここまで読まれた方、サンプルを触ってみられた方にはわかると思いますが、
乱数を使っているから・・・ (だから私は悪くない・・・) ってな事は安易に言えませんよね・・・
乱数をどう処理・料理するかで、いろいろ(な傾向は)作れますね・・・

時間を見つけて、こういう処理する時にはどうしたらいいのかな??・・・・
いろいろ頭をひねってみても無駄にはならないかも・・・

サンプルは以下
 バージョン 2007
 ファイル kEnt185.zip
 サイズ 92,818
※ ファイルは zip 形式
※ 2007 で作成した Excel(xls) ファイル
※ 2000 / 2003 でも動作

関連記事

2013/11/10

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。