For-Next の結果が正しくない？

Excel2003についてです。
セルC1からC800に、1から4までのいずれかの数値を入れていこうとしています。1の場合は25個、2を150個、3を300個、残りを4とします。
各数値をばらばらに散らしたいのでセルC1からC800を乱数で指定して、もし指定したセルが空白なら数値を入れ、空白でなければセルをもう一度指定しなおす、というマクロを作成しました。

下記のように記述（『残りを4』については省略、行頭の空白は全角です）したのですが、これを実際に走らせて見ると、各数値の指定した（はずの）個数と実際に入った数値の個数が一致しません。
セルをクリアしてもう一度実行してみると前回と個数が違う場合もあります。

VBAについては仕事でたまに触る程度で、まだまだ青二才です。
どうぞアドバイスをよろしくお願いします。

Dim A, B, C, D, n
　　For A = 1 To 3
　　　　Select Case A
　　　　　　Case 1
　　　　　　　　B = 25
　　　　　　Case 2
　　　　　　　　B = 150
　　　　　　Case 3
　　　　　　　　B = 300
　　　　End Select
　　　　For n = 1 To B
　　　　　　Do
　　　　　　　　C = Int(Rnd() * 1000) + 1
　　　　　　　　Cells(1, 1) = C
　　　　　　　　If C <= 800 Then
　　　　　　　　　　D = Cells(C, 3)
　　　　　　　　　　If D = "" Then
　　　　　　　　　　　　Cells(C, 3) = A
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Loop While C > 800
　　　　Next n
Next A

No.1 ベストアンサー 回答者： KenKen_SP 回答日時： 2008/02/26 02:27

こんにちは。

この手の問題で、よく使われる方法を2つ紹介しておきます。

　# コードの修正はしませんでした。すみません。

Sub SampleProc()
　　
　　' // データセット
　　Range("C1:C25").Value = 1
　　Range("C26:C175").Value = 2
　　Range("C176:C475").Value = 3
　　Range("C476:C800").Value = 4
　　' // チェック数式（参考用）
　　Range("E1:E4").Formula = "=ROW()"
　　Range("F1:F4").Formula = "=COUNTIF($C$1:$C$800,$E1)"
　　MsgBox "データセット終了"
　　' // 作業列（D列）にソート用乱数を設定し値化
　　With Range("D1:D800")
　　　　.Formula = "=Rand()"
　　　　.Value = .Value
　　End With
　　MsgBox "ソートキーセット終了"
　　' // 作業列をキーにしてソート
　　Range("C1:D800").Sort Key1:=Range("D1"), _
　　　　　　　　　　　　　Order1:=xlAscending, _
　　　　　　　　　　　　　Header:=xlGuess
　　MsgBox "ソート終了"
　　' // 作業列
　　Range("D1:D800").ClearContents
　　MsgBox "作業列消去"

End Sub

作業列を使わないのであれば、重複のない乱数を求める手法が
応用できます。考え方は難しいものではありませんが、中級者
向けの内容かな...？ こんな感じ。

Sub SampleProc2()
　　
　　Dim Src As Variant, i As Long
　　　　
　　' // 配列に要素をセットします
　　ReDim Src(1 To 800)
　　For i = 1 To UBound(Src)
　　　　Select Case i
　　　　　　Case Is <= 25:　Src(i) = 1
　　　　　　Case Is <= 175: Src(i) = 2
　　　　　　Case Is <= 475: Src(i) = 3
　　　　　　Case Else:　　　Src(i) = 4
　　　　End Select
　　Next
　　' // 配列をシャッフルします(例）50000回
　　Call ShuffleArray(Src, 50000)
　　' // 結果をセルに書き出します
　　Range("C1:C800").Value = Application.Transpose(Src)

End Sub

Private Sub ShuffleArray(ByRef Src As Variant, ByVal Count As Long)
　　
　　Dim tmp　　As Variant
　　Dim lLower As Long, lUpper As Long
　　Dim n1　　 As Long, n2　　 As Long
　　Dim i　　　As Long
　　
　　If Not IsArray(Src) Then Exit Sub
　　lLower = LBound(Src)
　　lUpper = UBound(Src)
　　Randomize Now()
　　For i = 1 To Count
　　　　' // 入れ替える配列の添え字 n1,n2 を乱数で求める
　　　　n1 = Int((lUpper - lLower + 1) * Rnd() + lLower)
　　　　n2 = Int((lUpper - lLower + 1) * Rnd() + lLower)
　　　　' // 値を入れ替える
　　　　tmp = Src(n1)
　　　　Src(n1) = Src(n2)
　　　　Src(n2) = tmp
　　Next

End Sub

この回答へのお礼

まったく違ったアプローチを示していただき、ありがとうございました。目からうろこが落ちる、というのを実感できました。

特に、1つ目の例を見たときには、自分がえらく複雑な手順を考えていたのがわかりました。

2つ目については、配列、Private Subプロシージャの使用、引数の渡し方など、私にとってこれまでなじみの薄い(というより避けて通ってきたかも)もので、勉強になりました。なんとか、各部分でそれぞれ何をしているのか理解できました。

本当に助かりました。ありがとうございました。

お礼日時：2008/02/26 10:05

No.2 回答者： tos_net 回答日時： 2008/02/26 03:07

セルに数値を代入できたかどうかがLoop Whileを抜ける条件になるので変数xを追加してみました。

　　Dim A, B, C, D, n, x

　　For A = 1 To 3
　　　　Select Case A
　　　　　　Case 1
　　　　　　　　B = 25
　　　　　　Case 2
　　　　　　　　B = 150
　　　　　　Case 3
　　　　　　　　B = 300
　　　　End Select
　　　　For n = 1 To B
　　　　　　x = 0　　'初期化
　　　　　　C = Int(Rnd() * 800) + 1
　　　　　　Do
　　　　　　　　If Cells(C, 3) = "" Then
　　　　　　　　　　Cells(C, 3) = A
　　　　　　　　　　x = 1　　'数値代入完了
　　　　　　　　Else
　　　　　　　　　　C = Int(Rnd() * 800) + 1　　'代入できなかったのでランダム値取り直し
　　　　　　　　End If
　　　　　　Loop While x = 0
　　　　Next n
　　Next A

この回答への補足

解決策を示していただき、ありがとうございました。

2つ目のFor文で、変数Bまでまわすので、その中の結果がどうであれ
Aの値がB個代入されていくはず、と考えていたのですが、
その中のif文で条件に当てはまらない場合の処置をしていないために
代入せずにそのまま Next n へ進んで次の n+1 のループに入ってしまった、という理解でいいでしょうか?

補足日時：2008/02/26 10:06