Results of 0 - 1 of about 0 (0.000 sec.)
- [[20120512134811]]
- @digest: a0bef89a5c21fb7200c3fdf67e493da8
- @id: 58881
- @mdate: 2012-05-14T00:30:07Z
- @size: 8401
- @type: text/plain
- #keywords: myclct (64439), コペ (23088), ポコ (21096), vsortm (11698), m12 (10886), 加ne (6450), ペン (5788), collection (5195), sortedlist (4979), getbyindex (4851), vbwhite (4390), 白文 (4333), randomize (3854), colorindex (3799), collections (3710), font (3190), 字" (3175), マナ (2811), rnd (2633), ary (2616), カ所 (2601), remove (2475), myrng (2451), system (1934), xlautomatic (1784), item (1728), ダム (1566), 要素 (1355), ラン (1204), 別案 (1108), hatch (1085), screenupdating (1065)
- 『範囲の中からランダムに5カ所白文字にしたい』（ポコペン）
いつもお世話になっております。 今日のご相談は、Range("D3:M12")の中の文字をランダムに5セル（箇所）だけ白文字にしたいのです。 過去のログを調べたましたが似たコードは見つかりませんでした。 初心者なのでよろしくお願いします。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にいれておいて たとえばその要素数が100個なら、最初に1〜100で値を取得して、取得した値をインデックスとして 抜き出した後、その要素をRemove。次に1〜99で値を取得して・・・・ といった方法を使ったりしている。 (ぶらっと) ---- ぶらっとさん、ありがとうございます（マナ） 修正版です。ポコペンさん見てるといいんだけど。 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になった5カ所のセルの内容を 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 "ランダムに5つのセルを空白にしました" 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)... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201205/20120512134811.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 98907 documents and 617517 words.
訪問者：