[[20120512134811]]　『範囲の中からランダムに５カ所白文字にしたい』（ポコペン）　ページの最後に飛ぶ

『範囲の中からランダムに５カ所白文字にしたい』（ポコペン）
いつもお世話になっております。
今日のご相談は、Range("D3:M12")の中の文字をランダムに５セル（箇所）だけ白文字にしたいのです。
過去のログを調べたましたが似たコードは見つかりませんでした。
初心者なのでよろしくお願いします。Excel2003，WindowsXP

たたき台としてどうぞ（マナ）

 Sub test()
    Dim v
    Dim i As Long
    Dim n As Long

    Range("D3:M12").ClearContents
    v = Range("D3:M12").Value

    For i = 1 To 5
        n = Int((UBound(v, 1) * UBound(v, 2)) * Rnd + 1)
        Range("D3:M12").Item(n).Value = "白文字"
    Next

 End Sub

こっちのほうがよかったかも（マナ）

 Sub test2()
    Dim myRng As Range
    Dim i As Long
    Dim n As Long

    Set myRng = Range("D3:M12")
    myRng.ClearContents
    For i = 1 To 5
        With myRng
            n = Int((.Columns.Count * .Rows.Count) * Rnd + 1)
            .Item(n).Value = "白文字"
        End With
    Next

 End Sub

  マナさん
 わたしの拙い文章にお応え頂きありがとうございました。
 的確な例題ありがとうございました、無事にでぎました。
 下のように直して使わせ頂きます。

   Dim v
    Dim i As Long
    Dim n As Long

    Range("D3:M12").Font.ColorIndex = 1

    v = Range("D3:M12").Value

    For i = 1 To 5
        n = Int((UBound(v, 1) * UBound(v, 2)) * Rnd + 1)
        Range("D3:M12").Item(n).Font.ColorIndex = 2
    Next
 （ポコペン）

 < n = Int((UBound(v, 1) * UBound(v, 2)) * Rnd + 1)
 5回繰り返すと、5個の数値の中には同じものが出てきそうな気がします。
 変化させるセル数は4個以下になったりしませんか?　　(Hatch)

あら、言われてみれば確かにそうですね（マナ）

 ポコペンさん、ごめんなさい。
 Hatchさん、こういう場合どうするのでしょう？教えてください。

 自分でも考えてみます。

 >こういう場合どうするのでしょう？教えてください。

 いろいろ方法があるんだろうね。こちらでやっているトランプめくりでは
 1.めくった数をDictionaryにでも格納しておいて、格納済みの数なら採用しない　とか
 2.今回の場合はちょっと面倒になるけど、たとえば全体のめくるべきセルアドレスをCollectionやDictionaryにいれておいて
　たとえばその要素数が１００個なら、最初に１～１００で値を取得して、取得した値をインデックスとして
　抜き出した後、その要素をRemove。次に１～９９で値を取得して・・・・

 といった方法を使ったりしている。

 (ぶらっと)

ぶらっとさん、ありがとうございます（マナ）

 修正版です。ポコペンさん見てるといいんだけど。
 Hatchさんも、ご指摘ありがとうございました。

 Sub test3()
    Dim myRng As Range
    Dim i As Long
    Dim n As Long
    Dim dic As Object
    Dim cnt As Long

    Set dic = CreateObject("Scripting.Dictionary")

    Set myRng = Range("D3:M12")
    myRng.Font.ColorIndex = 1

    Do
        With myRng
            n = Int((.Columns.Count * .Rows.Count) * Rnd + 1)
            If Not dic.exists(n) Then
                dic(n) = Empty
                cnt = cnt + 1
                .Item(n).Font.ColorIndex = 2
            End If
        End With
    Loop Until cnt = 5

    Set myRng = Nothing
    Set dic = Nothing

 End Sub

 私はこんなものを考えていました。
ダブりがあるか心配でしたので、一応1000回のループで5個となるのは確認しました。
組み合わせのランダム性などまでは考えていません(汗)
マナさんの.Item(n)を利用しています。　(Hatch)
Sub test_h()
    Dim i As Long, j As Long, cnt As Long
    Dim x(1 To 100)
    Dim y(1 To 100) As Integer
    Dim z(1 To 100) As Integer
    Randomize
        For i = 1 To 100
            x(i) = Rnd()
            y(i) = i
        Next i
        For i = 1 To 100
            z(i) = y(Application.Match(Application.Small(x, i), x, 0))
        Next i

        With Range("D3:M12")
            .Font.ColorIndex = 1
            For i = 1 To 5
                 .Item(z(i)).Font.ColorIndex = 2
            Next i
        End With
End Sub

Hatchさんありがとうございます（マナ）

 なるほど、こうするといいんですね。
 Rndで同じものが出ない限り、問題ありませんね。
 大変、勉強になりました。

 凹ペンです、続けて不備があり見てました。
 マナさん、Hatchさん、ぶらっとさん、ありがとうございます。
 考えに抜けているところがありとっても困っています。
 "D3:M12"の中からFont.ColorIndex = 1になった５カ所のセルの内容を
 P3から下のセルへと書き出したいのです。
 もう一度お知恵をお貸しください。

Hatchさんのを土台とするなら（マナ）

 For i = 1 To 5
     .Item(z(i)).Font.ColorIndex = 2
     Range("P" & i + 2).Value = .Item(z(i)).Value　　'★追加
 Next i

 じゃ、別案で。

 Sub Sample()
    Dim myClct As Collection
    Dim i As Long
    Dim x As Long
    Dim n As Long

    Application.ScreenUpdating = False
    Set myClct = New Collection

    For i = 1 To 100
        myClct.Add i
    Next

    With Range("D3:M12")
        For i = 1 To 5
            x = Int((100 - i + 1) * Rnd + 1)
            n = myClct(x)
            .Cells(n).ClearContents
            myClct.Remove x
        Next
    End With

    Set myClct = Nothing
    Application.ScreenUpdating = True
    MsgBox "ランダムに５つのセルを空白にしました"

 End Sub

 (ぶらっと)

ぶらっとさん、ありがとうございます（マナ）

 なるほど使用した要素は削除。とてもわかりやすいです。
 大変勉強になります。

ぶらっとさん案をベースにP3セル以下に書き出し（マナ）

 Sub Sample2()
    Dim myClct As Collection
    Dim i As Long
    Dim x As Long
    Dim n As Long

    Application.ScreenUpdating = False
    Set myClct = New Collection
    For i = 1 To 100
        myClct.Add i
    Next

    With Range("D3:M12")
        .Font.ColorIndex = 1
        For i = 1 To 5
            x = Int((100 - i + 1) * Rnd + 1)
            n = myClct(x)
            .Cells(n).Font.ColorIndex = 2
            Range("P" & i + 2).Value = .Cells(n).Value
            myClct.Remove x
        Next
    End With
    Set myClct = Nothing
    Application.ScreenUpdating = True

 End Sub

 別案で

 Sub test()
    Dim r As Range, i As Long
    Randomize
    Range("d3:m12").Font.ColorIndex = xlAutomatic
    With CreateObject("System.Collections.SortedList")
        For Each r In Range("d3:m12")
            .Item(Rnd) = r.Address
        Next
        For i = 0 To 4
            Range(.GetByIndex(i)).Font.Color = vbWhite
            Range("p3")(i + 1) = Range(.GetByIndex(i)).Value  '<- 追加
        Next
    End With
End Sub
(seiya)

System.Collections.SortedList ？？？（マナ）

 と思って過去ログ検索したら結構ありますね。
 自分のものに出来るよう勉強してみます。seiyaさん、ありがとうございました。

 ところでポコペンさん解決したかな～。
 私にはとてもありがたい回答を沢山いただけたんだけど
 もしポコペンさんを混乱させただけだったら、ごめんなさい。

 横やり失礼します。

 System.Collections.SortedList は .Net のオブジェクトなので Vista 以降では標準で使える
 ようになりましたが XP ではまだデフォルトではなかったので、すべての PC で使える
 オブジェクトとは考えない方がよいように思います。
http://officetanaka.net/excel/vba/tips/tips98.htm

 質問者さんの環境がXPだったので、一応ご参考までに。
 (Mook)

 >Excel2003，WindowsXP
 見落としました
 Objectを使用しない方法で

 Sub test()
    Dim a(), i As Long
    With Range("d3:m12")
        .Font.ColorIndex = xlAutomatic
        ReDim a(1 To .Count, 1 To 2)
        Randomize
        For i = 1 To .Count
            a(i, 1) = .Cells(i).Address
            a(i, 2) = Rnd
        Next
        VSortM a, 1, .Count, 2
        For i = 1 To 5
            Range(a(i, 1)).Font.Color = vbWhite
            Range("p3")(i).Value = Range(a(i, 1)).Value
        Next
    End With
End Sub

 Private Sub VSortM(ary, LB, UB, ref)
    Dim M As Variant, temp As Variant
    Dim i As Long, ii As Long, iii As Long
    i = UB: ii = LB
    M = ary(Int((LB + UB) / 2), ref)
    Do While ii <= i
        Do While ary(ii, ref) < M: ii = ii + 1: Loop
        Do While ary(i, ref) > M: i = i - 1: Loop
        If ii <= i Then
            For iii = LBound(ary, 2) To UBound(ary, 2)
                temp = ary(ii, iii): ary(ii, iii) = ary(i, iii)
                ary(i, iii) = temp
            Next
            ii = ii + 1: i = i - 1
         End If
    Loop
    If LB < i Then VSortM ary, LB, i, ref
    If ii < UB Then VSortM ary, ii, UB, ref
End Sub
(seiya)

コメント返信：

[ 一覧(最新更新順) ]

[[20120512134811]] 『範囲の中からランダムに５カ所白文字にしたい』（ポコペン） ページの最後に飛ぶ

[[20120512134811]]　『範囲の中からランダムに５カ所白文字にしたい』（ポコペン）　ページの最後に飛ぶ