お気持ちのみですが200p~差し上げます。エクセルのマクロについて質問です。


他の質問でで作って頂いたプログラム(最終的に作成されたプログラムコメントに示します)をコメントに示すように少し改変してください。

よろしくお願いします。

回答の条件
  • 1人5回まで
  • 登録:2007/03/09 14:48:17
  • 終了:2007/03/11 03:02:12

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982007/03/09 15:36:20

ポイント200pt
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
    a = Selection.Row
    
start:
    If Range("H" & a) = "" Then End
    a1 = a + 1
    Rows((a + 1) & ":" & (a + 3)).Select
    Selection.Insert Shift:=xlDown
    
    ab = Format(Time, "ss")
    For e1 = 0 To ab
        Randomize
    Next e1
   
    '三行分作成
    For e = 1 To 3
        'A~G列、M列、N列の複写
         Range("A" & a1) = Range("A" & a)
        Range("B" & a1) = Range("B" & a)
        Range("C" & a1) = Range("C" & a)
        Range("D" & a1) = Range("D" & a)
        Range("E" & a1) = Range("E" & a)
        Range("F" & a1) = Range("F" & a)
        Range("G" & a1) = Range("G" & a)
        Range("M" & a1) = Range("M" & a)
        Range("N" & a1) = Range("N" & a)
        
        f = 0
        
        While f = 0
            '最初にもってくる選択肢を決める
              c = Int(9 * Rnd)
            d = 2
            If c <= 3 Then d = 1
            If c >= 6 Then d = 3
            c = Int(9 * Rnd)
            d1 = 2
            If c <= 3 Then d1 = 1
            If c >= 6 Then d1 = 3
            c = Int(10 * Rnd)
            d2 = 2
            If c <= 5 Then d2 = 1
                
            '答えをセット
              Range("L" & a1) = d
            
            Select Case d
                Case 1
                    Range("H" & a1) = Range("H" & a)
                    Select Case d1
                        Case 1
                            Range("I" & a1) = Range("I" & a)
                            Select Case d2
                                Case 1: Range("J" & a1) = Range("J" & a): Range("K" & a1) = Range("K" & a)
                                Case 2: Range("J" & a1) = Range("K" & a): Range("K" & a1) = Range("J" & a)
                            End Select
                        Case 2
                            Range("I" & a1) = Range("J" & a)
                            Select Case d2
                                Case 1: Range("J" & a1) = Range("I" & a): Range("K" & a1) = Range("K" & a)
                                Case 2: Range("J" & a1) = Range("K" & a): Range("K" & a1) = Range("I" & a)
                            End Select
                        Case 3
                            Range("I" & a1) = Range("K" & a)
                            Select Case d2
                                Case 1: Range("J" & a1) = Range("I" & a): Range("K" & a1) = Range("J" & a)
                                Case 2: Range("J" & a1) = Range("J" & a): Range("K" & a1) = Range("I" & a)
                            End Select
                    End Select
                Case 2
                    Range("I" & a1) = Range("H" & a)
                    Select Case d1
                        Case 1
                            Range("H" & a1) = Range("I" & a)
                            Select Case d2
                                Case 1: Range("J" & a1) = Range("J" & a): Range("K" & a1) = Range("K" & a)
                                Case 2: Range("J" & a1) = Range("K" & a): Range("K" & a1) = Range("J" & a)
                            End Select
                        Case 2
                            Range("H" & a1) = Range("J" & a)
                            Select Case d2
                                Case 1: Range("J" & a1) = Range("I" & a): Range("K" & a1) = Range("K" & a)
                                Case 2: Range("J" & a1) = Range("K" & a): Range("K" & a1) = Range("I" & a)
                            End Select
                        Case 3
                            Range("H" & a1) = Range("K" & a)
                            Select Case d2
                                Case 1: Range("J" & a1) = Range("I" & a): Range("K" & a1) = Range("J" & a)
                                Case 2: Range("J" & a1) = Range("J" & a): Range("K" & a1) = Range("I" & a)
                            End Select
                    End Select
                Case 3
                    Range("J" & a1) = Range("H" & a)
                    Select Case d1
                        Case 1
                            Range("H" & a1) = Range("I" & a)
                            Select Case d2
                                Case 1: Range("I" & a1) = Range("J" & a): Range("K" & a1) = Range("K" & a)
                                Case 2: Range("I" & a1) = Range("K" & a): Range("K" & a1) = Range("J" & a)
                            End Select
                        Case 2
                            Range("H" & a1) = Range("J" & a)
                            Select Case d2
                                Case 1: Range("I" & a1) = Range("I" & a): Range("K" & a1) = Range("K" & a)
                                Case 2: Range("I" & a1) = Range("K" & a): Range("K" & a1) = Range("I" & a)
                            End Select
                        Case 3
                            Range("H" & a1) = Range("K" & a)
                            Select Case d2
                                Case 1: Range("I" & a1) = Range("I" & a): Range("K" & a1) = Range("J" & a)
                                Case 2: Range("I" & a1) = Range("J" & a): Range("K" & a1) = Range("I" & a)
                            End Select
                    End Select
                End Select
            
                f = 1
                For e1 = 2 To e
                    If Range("H" & a1) = Range("H" & a + e1 - 1) And Range("I" & a1) = Range("I" & a + e1 - 1) And Range("J" & a1) = Range("J" & a + e1 - 1) Then f = 0: Exit For
                Next e1
            
            Wend
        a1 = a1 + 1
    Next e
    
    Rows(a & ":" & a).Select
    Selection.Delete Shift:=xlUp
    a = a1 - 1
    GoTo start
End Sub

これで 重複しないでしょう。

id:ReoReo7

すばやい作成ありがとうございます!

試しましたが完璧です。

本当に価値のあるものができました。

ありがとうございました。

2007/03/11 03:00:52
  • id:taknt
    もしかして 英語のやつかな?
  • id:ReoReo7
    1)前回の仕様と、作って頂いたプログラム

    http://q.hatena.ne.jp/1172492376


    2)改変してほしいポイント
    【プラグラム1】は必要ありません。【プログラム2】において、
    「複製した行どうしで、入れ替えた選択肢に、同じ順序のものがない」
    ようにしてください【プログラム2’】。

    たとえば4つの選択肢が
    A,B,C,Dが元のならびならば

    (1)A,B,C,Dという選択肢の複製は許可する
    (2)A,B,C,Dという選択肢の複製を2度以上許可しない。
    (3)B,C,D,Aなどの選択肢も同様に、2度以上複製を許可しない。

    つまり最終的に生成される選択肢は、元のものと同一でもかまわないが、複製された3つの選択肢はそれぞれ重複がないこと。
  • id:taknt
    ああ なるほど。
    乱数を用いて ランダムにしているだけだから 既存の組あわせと 同様になったら 別の組み合わせにしないと ダメということですね。
  • id:ReoReo7
    takntさん

    そうです。以前のプログラム非常に順調に動いております。
    特に【プログラム1】でピリオドに対応して頂いたところが重宝しています。

    上記のように【プログラム2】のみ少し改変を要しております。よろしくお願いします。
  • id:ReoReo7
    おかげさまでよく動いています。

    さて、もともとH列(選択肢1)にある答えは、H~J列(選択肢1~3)へがランダムに設定される仕様ですが、マクロを利用してみたところおおよそ


    選択肢1:50%
    選択肢2:25%
    選択肢3:25%

    の確率で遷移します。

    これを何とか修正できませんでしょうか?
  • id:taknt
    c = Int(9 * Rnd)
    d = 2
    If c <= 3 Then d = 1
    If c >= 6 Then d = 3
    c = Int(9 * Rnd)
    d1 = 2
    If c <= 3 Then d1 = 1
    If c >= 6 Then d1 = 3
    c = Int(10 * Rnd)
    d2 = 2
    If c <= 5 Then d2 = 1

    この部分で 配置を決定しています。
    この比率をちょっと調整しないとダメですね。
  • id:taknt
    乱数を用いてますので、場合によって比率は 違うみたいですね。
    ただ 1に選択されるのが 50%を越える場合があるので

    c = Int(9 * Rnd)
    d = 2
    If c <= 3 Then d = 1
    If c >= 6 Then d = 3

    の部分を
    c = Int(900 * Rnd)
    d = 2
    If c <= 250 Then d = 1
    If c >= 575 Then d = 3

    ぐらいに調整したらいいかもしれませんね。

    ここの
    If c <= 値1 Then d = 1
    If c >= 値2 Then d = 3
    で値1と値2を大きくしたり小さくしたりすれば%が 変わります。

    なお、値1は、値2より小さな値にしてください。

  • id:ReoReo7
    ありがとうございます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません