忍者ブログ
日常だったりネタだったり作品の進捗だったり……色々書きます。不定期に。
11
  • 1
  • 2
  • 3
  • 4
  • 5
  • 6
  • 7
  • 8
  • 9
  • 10
  • 11
  • 12
  • 13
  • 14
  • 15
  • 16
  • 17
  • 18
  • 19
  • 20
  • 21
  • 22
  • 23
  • 24
  • 25
  • 26
  • 27
  • 28
  • 29
  • 30
  • 管理画面

    Access VBA―マウスホイール制御

    こんばんは若槻です。きりちゃんのところにぽんと投下してきた
    VBAの修正版が出来たから載っけてみます。


    「Access VBA マウスホイール制御」
    ○やりたいこと
    →フォームでマウスホイールをするとレコードが移動してしまうので
     それをなくす

    ○ソース

    Dim bbb As Integer

    '=============================================
    ' フォームの読み込み時
    '=============================================
    Private Sub Form_Load()
      bbb = 0
    End Sub

    ☆やっていること
    フォームの読み込み時に変数bbbに0を入れる


    '=============================================
    'レコード移動時
    '=============================================
    Private Sub Form_Current()
     If Me.NewRecord Then Exit Sub
     
     Me.[コントロール名].SetFocus
     Me.Dirty = True
    End Sub

    ☆やっていること
    レコード移動時の処理。
     1.次のレコードが新しいレコードの時は作用しない
     2.どれでもいいからコントロールを選んでおく。これを選ばないとエラーになる
     3.「Dirty」はカレントレコードの変更の有無を表す。今はTrueなので変更有り 
       →変更有り=更新前処理が入る


    '=============================================
    ' マウスホイールを動かした時
    '=============================================
    Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
      bbb = Count
    End Sub

    ☆やっていること
    マウスホイールが動かされたらbbbにCountの値を入れる
    (Countの値=ホイールされて動こうとしているレコードの数)


    '=============================================
    ' レコードに変更があった時
    '=============================================
    Private Sub Form_BeforeUpdate(Cancel As Integer)
      If bbb <> 0 Then
        Cancel = True
        bbb = 0
      End If
    End Sub

    ☆やっていること
    bbbの値が0でない時にCancelをTrueにして処理をキャンセルする。
    ※1ここでキャンセルされると移動もキャンセルになる
    ※2判断は必ず「0でない」にする。bbbの値はマイナス値にもなる
    ※3bbbの値を初期化しておく
    (上のレコード移動時の処理を超えると自動的に入ってくる)


    =======================
    ◎修正前
    →前回はString型で文字を入れる感じでやっていたのですが、
     思いっきりホイールすると動いてしまったので数値型にしました。
     (きりちゃん報告。自分で確認しろよって話ですね分かりまs)

    細かい原理は理解しきれてませんが多分一気にやるとどっかしらで
    値が入らなくなるんだと思います。
    というわけで数値型でFA。

    ※注意※
    上のソースは若槻が触る分には特に問題はありませんでしたが、
    プログラムによっては不具合を起こす可能性、動作しない可能性も
    あります。その場合にこちらで責任を取ることは出来ませんので
    ご了承ください。



    =2013/07/04 追記=
    VBAやPC系で学んだことをまとめる備忘録ブログを
    作りました。


    若風備忘録


    内容は徐々に増えますが、こちらの内容もそちらに
    入っています。

    この記事に関しては説明等の内容は特に変わりません。






    以下拍手返信です。
    サイト拍手含め名無しの拍手の方々もありがとうございます!

     


    拍手[4回]

    PR

    VBA「演習-学生名簿」続き9

    こんばんは若槻です。本日いきなり仕事が増えました。
    仕事があるのはいいんです。だが何で暇な時と忙しい時の
    波が激しいんだ((゜д゜;))!?
    大波小波にもほどがある……orz



    さて、本日は昨日の続きです。
    って言っても、たいしたことじゃないです。長いだけ。


    ====================================================
    ◎システム名 「演習-学生名簿」
    ====================================================
    ~現在ある内容~
    ・グループ分け      ←終了
    ・学年別  ←簡単1      ←終了
    ・学校別         ←終了
    ・性別ごと ←簡単2   ←終了
    ・配役配置        ←終了
    ・試合          ←終了
    ・検索
    ・選抜          ←終了
    ・動き
    ・条件別グループ分け

    本日は「動き」の続きをおしゃべりします。

    9.動き
    ○やりたいこと
    これは番外のお遊びソースですね。
    学生名簿演習には正直直接関係はありません。
    遊び道具を作りたい方は、って感じでしょうか^^;

    ではスタート。


    ○ソース
    ~~~~~~~ソース3.-ここから~~~~~~~~
    '=======================================================
    '動作-文字タイプ
    '=======================================================
    Sub MojiType()
    [1]
      SheetSet
      WH13.Range("X1:BG50").Interior.Pattern = xlPatternNone
     
      LG = 2   '塗りつぶし用-行
      LR = 25  '塗りつぶし用-列
     
    [2]
      Kotoba2 = InputBox(Title:="入力", prompt:="アルファベットで入力してください。" & _
                Chr(10) & Chr(13) & "@マークで改行されます")
      If Kotoba2 = "" Then
        Exit Sub
      End If
     
    [3]
      Ren = Len(Kotoba2)
      j = 1  'Kotoba2を回す用
      Do Until j > Ren
        Kotoba = Mid(Kotoba2, j, 1)
        If Kotoba = "@" Then
          LR = 25
          LG = LG + 8
        Else
          Alphabet
          If LR >= 50 Then
            LR = 25
            LG = LG + 8
          Else
            LR = LR + 2
          End If
        End If
        j = j + 1
      Loop
    End Sub
    ~~~~~~~ソース3.-ここまで~~~~~~~~

    ソース3でやってること→アニメーション2、文字タイプ
    △これはインプットボックスに入力した値がExcel上に記述されていくソースです。
     ただし動作するのは英大文字のみとなっています。
     小文字で入れても大文字で入れても全部大文字です
     
    [1]初期動作→塗りつぶしをなくしたり変数の値を初期値にする
    [2]記述したい言葉を入力し、変数Kotoba2に代入。
     何も入力しなかった場合は処理を抜ける
    MessageBox1.JPG







    MessageBox2.JPG








    [3]上の処理で「Excel」と入力したのを前提とします。
     1.変数RenにKotoba2の文字数を入れる(今回は5文字)
     2.変数KotobaにKotoba2のj番目から1文字分を格納
     3.Kotobaが「@」の場合は列数のLRを初期値に戻し、現在の行数に8を足す
     「@」以外の時はマクロ「Alphabet」を呼び出して実行。
     それから列数が50以上の時は列数を初期値に戻し、行数に8を追加。
     列数が50を超えていない場合は列数に2を追加する。

    Kekka1.JPG










    ☆ 以下に記すのはマクロ「Alphabet」です。長いのでご注意を ☆
    ~~~~~~~ソース4.-ここから~~~~~~~~
    =======================================================
    'アルファベットごとに塗りつぶしを変える
    '=======================================================
    Sub Alphabet()
      Select Case Kotoba
        '◆◇◆ A ◆◇◆
        Case "A", "a"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
         
         
        '◆◇◆ B ◆◇◆
        Case "B", "b"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓4列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG + 1, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 3, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
         
        '◆◇◆ C ◆◇◆
        Case "C", "c"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1  '次の列へ
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          WH13.Cells(LG + 2, LR).Interior.Pattern = xlPatternNone
         
         
        '◆◇◆ D ◆◇◆
        Case "D", "d"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1  '次の列へ
          i = LG + 1
          Do Until i > LG + 3
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
         
         
        '◆◇◆ E ◆◇◆
        Case "E", "e"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
         
        '◆◇◆ F ◆◇◆
        Case "F", "f"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
         
        '◆◇◆ G ◆◇◆
        Case "G", "g"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
         
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓4列目
          LR = LR + 1  '次の列へ
          i = LG
          Do Until i > LG + 4
            If i <> LG + 1 Then
              WH13.Cells(i, LR).Interior.ColorIndex = 1
              For h = 1 To 10000
                DoEvents
              Next h
            End If
            i = i + 1
          Loop
         
         
        '◆◇◆ H ◆◇◆
        Case "H", "h"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop


        '◆◇◆ I ◆◇◆
        Case "I", "i"
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓3列目
          LR = LR + 1
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h


        '◆◇◆ J ◆◇◆
        Case "J", "j"
          i = LG
          Do Until i > LG + 4
            If i <> LG + 1 And i <> LG + 2 Then
              WH13.Cells(i, LR).Interior.ColorIndex = 1
              For h = 1 To 10000
                DoEvents
              Next h
            End If
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓4列目
          LR = LR + 1
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h


        '◆◇◆ K ◆◇◆
        Case "K", "k"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          WH13.Cells(LG + 1, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          WH13.Cells(LG + 3, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓4列目
          LR = LR + 1
          WH13.Cells(LG, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h


        '◆◇◆ L ◆◇◆
        Case "L", "l"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          WH13.Cells(LG + 4, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
        
       
        '◆◇◆ M ◆◇◆
        Case "M", "m"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG + 1, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓4列目
          LR = LR + 1
          WH13.Cells(LG + 1, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓5列目
          LR = LR + 1
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
         
         
        '◆◇◆ N ◆◇◆
        Case "N", "n"
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          '----------------------------------------↓2列目
          LR = LR + 1  '次の列へ
          WH13.Cells(LG + 1, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓3列目
          LR = LR + 1
          WH13.Cells(LG + 2, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓4列目
          LR = LR + 1
          WH13.Cells(LG + 3, LR).Interior.ColorIndex = 1
          For h = 1 To 10000
            DoEvents
          Next h
          '----------------------------------------↓5列目
          LR = LR + 1
          i = LG
          Do Until i > LG + 4
            WH13.Cells(i, LR).Interior.ColorIndex = 1
            For h = 1 To 10000
              DoEvents
            Next h
            i = i + 1
          Loop
          

    ※ソース4の残りは追記の中に格納しています。

    ~~~~~~~ソース4.-ここまで~~~~~~~~


    'ソース4でやってること→文字タイプ、アルファベットに塗りつぶし
     △長いですがやっているのはその文字になるように1セルずつ
      塗りつぶしているだけです。
      今回は徐々に描かれるようにしているので
      「For h = 1 To 10000
            DoEvents
          Next h」
      が、入ります。これがないと一気に塗られます。

     ※うまく入りきらなかったものがやけに広くなったり大きくなったり
      していますので、もしこのプログラムを実行なさった方がいらっしゃり、
      「なんか違和感ある」と思われたらどうぞ改変なさってください。
      そして若槻に教えてくだs(ry

    a489c499.JPG















     

    ~~~~~~~ソース5.-ここから~~~~~~~~
    '=======================================================
    '塗りつぶし無しにする
    '=======================================================
    Sub NothingColor()
      SheetSet
      WH13.Cells.Interior.Pattern = xlPatternNone
    End Sub
    ~~~~~~~ソース5.-ここまで~~~~~~~~

    ソース5でやってること→シート「動き」の塗りつぶしを全て無しにする

     

    以上で「動き」は終了です。
    お疲れ様でした。


     

    拍手[1回]

    VBA「演習-学生名簿」続き8

    こんばんは若槻です。最近仕事がなかったのですが
    明日から忙しくなる予感がひしひしと……寝る時間を
    確保出来るなら何でもいいですorz


    さて、本日は久々にVBAのおしゃべりです。
    需要なんて知っちゃこっちゃありません←


    ====================================================
    ◎システム名 「演習-学生名簿」
    ====================================================
    ~現在ある内容~
    ・グループ分け      ←終了
    ・学年別  ←簡単1      ←終了
    ・学校別         ←終了
    ・性別ごと ←簡単2   ←終了
    ・配役配置        ←終了
    ・試合          ←終了
    ・検索
    ・選抜          ←終了
    ・動き
    ・条件別グループ分け

    本日は「動き」をおしゃべりします。
    そしてこっそり長いので2回に分けます。
    難しいんじゃなくて、長い。

    9.動き
    ○やりたいこと
    これは番外のお遊びソースですね。
    学生名簿演習には正直直接関係はありません。
    遊び道具を作りたい方は、って感じでしょうか^^;

    ではスタート。


    ○ソース
    ~~~~~~~ソース1.-ここから~~~~~~~~
    '=======================================================
    '動作-まばたき
    '=======================================================
    Sub Anmtion()
      SheetSet
      j = 1
      Do Until j > 3
        [1]
      WH13.Range("C4:C8,E4:E8,D10:D12").Interior.ColorIndex = 1
        Application.Wait Now() + TimeValue("00:00:01")
       
        [2]
        WH13.Range("C4:C8,E4:E8,D10:D12").Interior.Pattern = xlPatternNone
        WH13.Range("C6,E6,D10:D12").Interior.ColorIndex = 1
        Application.Wait Now() + TimeValue("00:00:01")
       
        j = j + 1
      Loop
    End Sub
     ~~~~~~~ソース1.-ここまで~~~~~~~~

    ソース1でやってること→アニメーション1
    [1]指定しているセルの背景色を黒にする
     1秒間だけプログラムを待たせる
      
      「 Application.Wait 時間 」
      →「時間」の分だけ処理を一時停止
     「 Now() + TimeValue("00:00:01") 」
      →「Now」が現在の時間で、TimeValueの値を足すことで
       現在の時間から指定した時間分だけ待たせることが出来る
      
    [2]指定したセルの背景色を無しにし、同時に別箇所を黒くする
     上と同様に1秒間だけ待機させる


    △このソース1のプログラムを実行すると3回分の瞬きが
     繰り返されます

    Mabataki1.JPG











    Mabataki2.JPG












    Mabataki3.JPG










     

    ~~~~~~~ソース2.-ここから~~~~~~~~  
    '=======================================================
    '動作-表情おみくじ
    '=======================================================
    Sub Omikuji()
      SheetSet
      j = 1
     
      WH13.Range("K2:T11").Interior.Pattern = xlPatternNone
     
      Randomize
      h = Int(Rnd() * 3) + 1
     
      Select Case h
        Case 3
          WH13.Range("L4,N4,Q4,S4").Interior.ColorIndex = 1
          WH13.Range("M3,R3,N8,Q8").Interior.ColorIndex = 1
          WH13.Range("N7:Q7,O9:P9").Interior.ColorIndex = 1
        Case 2
          WH13.Range("L4,N4,Q4,S4").Interior.ColorIndex = 1
          WH13.Range("M5,R5,N8:Q8").Interior.ColorIndex = 1
        Case 1
          WH13.Range("L4,N4,Q4,S4,M5,R5").Interior.ColorIndex = 1
          WH13.Range("N9,Q9,O8:P8").Interior.ColorIndex = 1
      End Select
    End Sub
     ~~~~~~~ソース2.-ここまで~~~~~~~~

    ソース2でやってること→ランダムで出した値によって塗りつぶす範囲を変える
     1.対象範囲の塗りつぶしを無しにする
     2.変数hにランダムで値を入れる
     3.hの値によって場合わけを行い、表情を作る

    Omikuji_Fine.JPG














    Omikuji_Usual.JPG













    Omikuji_Bad.JPG













     

    以上で今回の「動き」は終了です。
    お疲れ様でした。



    以下拍手返信です。

     

    拍手[1回]

    VBA「演習-学生名簿」続き7

    こんばんは若槻です。GWまであと1日。GW入ったら仕上げられる奴は
    なるべく全部仕上げられるように頑張りたいと思います(-ω-)


    さて、それでは本日はそろそろ仕上げなのでまたVBAで。


    ====================================================
    ◎システム名 「演習-学生名簿」
    ====================================================
    ~現在ある内容~
    ・グループ分け      ←終了
    ・学年別  ←簡単1      ←終了
    ・学校別         ←終了
    ・性別ごと ←簡単2   ←終了
    ・配役配置        ←終了
    ・試合          ←終了
    ・検索
    ・選抜
    ・動き
    ・条件別グループ分け

    本日は「選抜」をおしゃべりします。

     

    8.選抜
    ○やりたいこと
    前回の「試合」同様単純にメンバーを振り分けているだけです。
    A~Fの6グループに適当に11人振り分ける

    ○ソース
    ~~~~~~~ソース1.-ここから~~~~~~~~
    '============================================================
    '選抜抜き出し
    '============================================================
    Sub Senbatu()
    [1]
      SheetSet
      DontLook
     
      SyokiCopy
      WH2.Range("1:1").Delete
     
      WH11.Cells.Delete
      '項目名の入力
      WH11.Range("A1,G1").Value = "選抜タイプ"
      WH11.Range("B1,H1").Value = "名前"
      WH11.Range("C1,I1").Value = "性別"
      WH11.Range("D1,J1").Value = "学校"
      WH11.Range("E1,K1").Value = "学年"
     

      '罫線を引く-2重線
      WH11.Range("A1:E1").Borders(xlEdgeBottom).LineStyle = xlDouble
      WH11.Range("G1:K1").Borders(xlEdgeBottom).LineStyle = xlDouble
     
      '罫線を引く-中太線
      WH11.Range("A12:E12").Borders(xlEdgeBottom).Weight = xlMedium
      WH11.Range("A23:E23").Borders(xlEdgeBottom).Weight = xlMedium
      WH11.Range("G12:K12").Borders(xlEdgeBottom).Weight = xlMedium
      WH11.Range("G23:K23").Borders(xlEdgeBottom).Weight = xlMedium
     
      '罫線を引く-囲い線1
      WH11.Range("A1:E1").Borders(xlEdgeTop).LineStyle = xlContinuous
      WH11.Range("E1:E34").Borders(xlEdgeRight).LineStyle = xlContinuous
      WH11.Range("A34:E34").Borders(xlEdgeBottom).LineStyle = xlContinuous
      WH11.Range("A1:A34").Borders(xlEdgeLeft).LineStyle = xlContinuous
     
      '罫線を引く-囲い線2
      WH11.Range("G1:K1").Borders(xlEdgeTop).LineStyle = xlContinuous
      WH11.Range("K1:K34").Borders(xlEdgeRight).LineStyle = xlContinuous
      WH11.Range("G34:K34").Borders(xlEdgeBottom).LineStyle = xlContinuous
      WH11.Range("G1:G34").Borders(xlEdgeLeft).LineStyle = xlContinuous
     
      '罫線を引く-区切り線
      WH11.Range("A1:A34").Borders(xlEdgeRight).LineStyle = xlContinuous
      WH11.Range("G1:G34").Borders(xlEdgeRight).LineStyle = xlContinuous
     
     
      '選抜名入力
      WH11.Range("A2:A12").MergeCells = True
      WH11.Range("A2").Value = "選抜A"
      WH11.Range("A13:A23").MergeCells = True
      WH11.Range("A13").Value = "選抜B"
      WH11.Range("A24:A34").MergeCells = True
      WH11.Range("A24").Value = "選抜C"
      WH11.Range("G2:G12").MergeCells = True
      WH11.Range("G2").Value = "選抜D"
      WH11.Range("G13:G23").MergeCells = True
      WH11.Range("G13").Value = "選抜E"
      WH11.Range("G24:G34").MergeCells = True
      WH11.Range("G24").Value = "選抜F"
     
      '中央寄せ
      WH11.Range("A1:E1").HorizontalAlignment = xlCenter
      WH11.Range("G1:K1").HorizontalAlignment = xlCenter
      WH11.Range("A2,A13,A24,G2,G13,G24").HorizontalAlignment = xlCenter
     
      '選抜-太字と角度変更
      WH11.Range("A2,A13,A24,G2,G13,G24").Font.Size = 14
      WH11.Range("A2,A13,A24,G2,G13,G24").Font.Bold = True
      WH11.Range("A2,A13,A24,G2,G13,G24").Orientation = 45
     
     
    [2] 
      '選抜A
      h = 2
      Do Until h > 12
        GroupNo = 1
        SenbatuKaiten
      Loop
     
      '選抜B
      h = 13
      Do Until h > 23
        GroupNo = 1
        SenbatuKaiten
      Loop
     
      '選抜C
      h = 24
      Do Until h > 34
        GroupNo = 1
        SenbatuKaiten
      Loop
     
      '選抜D
      h = 2
      Do Until h > 12
        GroupNo = 2
        SenbatuKaiten
      Loop
     
      '選抜E
      h = 13
      Do Until h > 23
        GroupNo = 2
        SenbatuKaiten
      Loop
     
      '選抜F
      h = 24
      Do Until h > 34
        GroupNo = 2
        SenbatuKaiten
      Loop
     
     
    [3] 
      '列幅のオートフィット
      LR = WH11.UsedRange.Columns.Count
      For i = 1 To LR
        WH11.Rows(i).EntireColumn.AutoFit
      Next
     
      WH11.Select
      WH11.Range("M1").Select
     
      OKLook
    End Sub
     ~~~~~~~ソース1.-ここまで~~~~~~~~

    ソース1でやってること→メイン動作
    [1]初期動作
     1.学生一覧をコピーして1行目の項目行を削除
     2.シート「選抜」内のデータを空にする
     3.項目名を格納 
     4.各所に罫線を引く
     5.グループ名を入れてセルを結合
     6.中央寄せやフォント等の変更を行う

     ※「Range("A1").Font.Size = 14」
      →A1のフォントサイズを14にする。ここで指定される値は
       通常のExcelで設定する値と同様に考える
     ※「Range("A1").Font.Bold = True」
      →A1のフォントに太字が追加される(外す場合はFalseにする)
      →ちなみに斜体は「.Italic = True」にすればよい
     ※「Range("A1").Orientation = 45」
      →A1の配置が45度の角度で傾く


    [2]各グループに振り分け。変数hは行数、変数GroupNoは列数
     ※GroupNoの場合、A~Cが1、D~Fが2となる
     →マクロSenbatuKaitenを呼び出し(後述)
    [3]最終処理
     →最終列までのオートフィット


    ~~~~~~~ソース2.-ここから~~~~~~~~
    '値入れ
    Sub SenbatuKaiten()
      LG = WH2.Range("A65536").End(xlUp).Row
      Randomize
      j = Int(Rnd() * LG) + 1
      Select Case GroupNo
        Case 1
          WH11.Range("B" & h).Value = WH2.Range("B" & j).Value
          WH11.Range("C" & h).Value = WH2.Range("D" & j).Value
          WH11.Range("D" & h).Value = WH2.Range("E" & j).Value
          WH11.Range("E" & h).Value = WH2.Range("F" & j).Value
        Case 2
          WH11.Range("H" & h).Value = WH2.Range("B" & j).Value
          WH11.Range("I" & h).Value = WH2.Range("D" & j).Value
          WH11.Range("J" & h).Value = WH2.Range("E" & j).Value
          WH11.Range("K" & h).Value = WH2.Range("F" & j).Value
      End Select
      WH2.Range(j & ":" & j).Delete
      h = h + 1
    End Sub
     ~~~~~~~ソース2.-ここまで~~~~~~~~

    ソース2でやってること→値の転記
     1.ランダムで選んだ値をjに代入
     2.GroupNoの値によって場合分けをし、データを転記
     3.転記された元データの行を削除

    e47a6309.JPG















    以上で「選抜」は終了です。
    お疲れ様でした。


    ~おまけ~
    「同一セル内でもこの部分だけを変えたい!」ということってありませんか?
    そんな時はこれ。

    「Characters(開始位置、文字数)」

    配置的には

    「Range("A1").Characters(4, 3) .Font.Size = 15」

    で、たとえばA1に「AbcDefGhi」という文字列が入っている場合、
    上の設定だと「Def」の部分の文字サイズが15になります。
    ※ちなみに同一セル内に複数の設定を入れることも可能

    <Ex>
    1.Range("A2").Value = Range("A1").Value
      WH11.Range("A2").Characters(1, 1).Font.Italic = True
    →1文字目だけ斜体になる
     
    2.Range("A3").Value = Range("A1").Value
      Range("A3").Characters(1, 1).Font.Bold = True
    → 1文字目だけ太字になる
     
    3.Range("A4").Value = Range("A1").Value
      With Range("A4")
        .Characters(1, 1).Font.Bold = True
        .Characters(2, 1).Font.Italic = True
        .Characters(1, 1).Font.Size = 15
      End With
    →1文字目が太字でフォントサイズ15に、2文字目が斜体になる
     

    07a3741e.JPG







     


    拍手[1回]

    VBA「演習-学生名簿」続き6

    こんばんは若槻です。以前TOUYAさんに回していただいたバトンの
    下書きをしていました。とうまくんから匙投げられたからこれを
    4,000Hitのお礼絵に転用しようと画策中←


    さて、本日は連続になりますがVBAのおしゃべりです。
    需要がなかろうとしっちゃこっちゃありません(笑



    ====================================================
    ◎システム名 「演習-学生名簿」
    ====================================================
    ~現在ある内容~
    ・グループ分け      ←終了
    ・学年別  ←簡単1      ←終了
    ・学校別         ←終了
    ・性別ごと ←簡単2   ←終了
    ・配役配置        ←終了
    ・試合   
    ・検索
    ・選抜
    ・動き
    ・条件別グループ分け

    本日は試合をおしゃべりします。

     

    7.試合
    ○やりたいこと
    試合といってもやるのは組み合わせを作るだけです。
    キャラクターに何かしら値を持たせれば試合まで行うのも可能ですかね。
    ですが今回はユーザーフォームで指定した条件ごとに
    組み分けをする、というところまでになります。


    ○使用変数
    Public Kumiawase As String
    Public Gakunen As Integer
    Public Kaisuu As String      

    'ユーザーフォーム用
    Public ListCNT As Integer  
    Public Naiyou(2) As String
    Public Kakuho As Integer 


    ○ソース
    ~~~~~~~ソース1.-ここから~~~~~~~~
    '================================================
    '試合配置
    '================================================
    Sub SiaiHaiti()
      SheetSet
      DontLook

    [1] 
      '=============ウィンドウ枠の解除
      ActiveWindow.FreezePanes = False
     
    [2]
      '====================WH8のデータの削除
      LG = WH8.Range("A65536").End(xlUp).Row
      If LG > 1 Then
        WH8.Range("A2:O" & LG).Delete
      End If
     
    [3]
      '=====WH2にWH1のデータをコピーして並び替え===========
      SyokiCopy
     
    [4] 
      'ユーザーフォームの読み出し
      UserForm1.Show

    [5] 
      '==========組み合わせ==========
      Select Case True
        Case Kumiawase = "男子"
          OutGirl
        Case Kumiawase = "女子"
          OutBoy
      End Select
     
      '学年
      Select Case True
        Case Gakunen = 1
          OutOtherFirst
        Case Gakunen = 2
          OutOtherSecond
        Case Gakunen = 3
          OutOtherThird
        Case Gakunen = 12
          OutThird
        Case Gakunen = 13
          OutSecond
        Case Gakunen = 23
          OutFirst
      End Select
     
      '人数ごとに振り分け
      Select Case Nin
        Case 1
          OneOnOne
        Case 2
          MixDouble
      End Select
     
    [6] 
      '行の高さ変更
      WH8.Range("1:" & LG).RowHeight = 22.5
     
      '罫線
      With WH8.Range("A1:I" & LG)
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
      End With
     
     
      '背景色
      WH8.Range("A1:I" & LG).Interior.ColorIndex = 2
     
      '全体を中央寄せ
      WH8.Range("A:I").HorizontalAlignment = xlCenter
     
      WH8.Select
      'ウィンドウ枠の固定
      WH8.Range("2:2").Select
      ActiveWindow.FreezePanes = True
      WH8.Range("J2").Select
      OKLook
    End Sub

     ~~~~~~~ソース1.-ここまで~~~~~~~~

    ソース1でやってること→メイン動作。各マクロの呼び出し
    [1]ウィンドウ枠固定の解除
     →何回か前にも書いたかもしれませんが、これはやっておかないと
      最終のウィンドウ枠固定がうまく機能しなくなってしまいます。

    [2]A列の2行目からO列のLG(最終行)目までをデリート
    [3]学生一覧のデータを作業用のシート「並べ替え」にコピー
    [4]ユーザーフォームの呼び出し
     →ユーザーフォーム自体のコードは下で喋りますのでここでは
      「呼び出しましたよ」ってことだけお伝えします。
     ※ちなみにここでは「組み合わせ」「人数」「学年」を選択し、
      その結果ごとに以降の行動が決まります。

    [5]ユーザーフォーで選択した値によって行を選抜していく
     「組み合わせ」→「混合」:何もしない
             「男子」:OutGirl = 女子の行を削除
             「女子」:OutBoy = 男子の行を削除
            
     「学年」   →「全学年」 :何もしない
             「1年と2年」:OutThird = 3年の行を削除
             「1年と3年」:OutSecond = 2年の行を削除
             「2年と3年」:OutFirst = 1年の行を削除
             「1年」   :OutOtherFirst = 1年以外を削除
             「2年」   :OutOtherSecond = 2年以外を削除
             「3年」   :OutOtherThird = 3年以外を削除
            
     「人数」   →「1人」:1対1の組み合わせを作る
             「2人」:2対2の組み合わせを作る


    [6]最終処理
     1.行の高さの変更
      ◎行の高さと列の幅◎
      .RowHeight = 数字  ←行の高さは「ポイント」で表されています
      .ColumnWidth = 数字 ←列の幅は「標準フォントで何文字分の幅」で表されます
                 いまいち分かりづらいので若槻は列幅を決めるときは
                 一回現在の列幅を出してから調整してます。
                 分かる人なら多分すぐに分かるかと!
      ※標準フォント=「ツール」→「オプション」→「全般タブ」で見られます
      
     2.罫線を引く
     3.データが入ったところにだけ背景色を白にする
     4.全体を中央寄せ
     5.ウィンドウ枠を固定

     

    ~~~~~~~~ソース2.-ここから~~~~~~~~
    '==================================================
    '性別【女子】の行を消す
    '==================================================
    Sub OutGirl()
      LG = WH2.Range("A65536").End(xlUp).Row
      k = 2
      Do Until k > LG
        If WH2.Range("D" & k).Value = "女" Then
          WH2.Range(k & ":" & k).Delete
          k = k - 1
        End If
        k = k + 1
      Loop
    End Sub
    ~~~~~~~~ソース2.-ここまで~~~~~~~~

    ソース2でやってること→性別が「女」の行を削除する
     △最終行を求め、Do Loopを回して1行ずつ見ていきます。
      一致した行は消し、1行分が減ったので変数kからも
      1を引きます。
      ※前にも書きましたが、ここで1を減らさないと
       消した分だけ見ている行がずれていってしまい、
       最終的に消えるべき行が生き残ってしまいます。

     ☆以下に
       ・OutBoy
       ・OutOtherFirst
       ・OutOtherSecond
       ・OutOtherThird
       ・OutFirst
       ・OutSecond
       ・OutThird
      が続きますが、やっていることはOutGirlと同じなので省略します。

     


    ~~~~~~~~ソース3.-ここから~~~~~~~~
    '=============================================
    '対戦-1対1
    '=============================================
    Sub OneOnOne()
    [1]
      '=====全体の人数が奇数だった時に偶数に調整
      LG = WH2.Range("A65536").End(xlUp).Row
      If LG Mod 2 = 1 Then
        LG2 = LG - 1
        Kaisuu = Int(LG2 / 2)
      Else
        Kaisuu = Int(LG / 2)
      End If

    [2]
      YobunIdou

    [3]
      Ramdam
     
      j = 2  'WH8-行用
      h = 1  'WH8-列用
      Do Until j > Kaisuu
        Select Case h Mod 2
          Case 1
            WH8.Range("A" & j).Value = WH2.Range("B" & i).Value
            WH8.Range("B" & j).Value = WH2.Range("E" & i).Value
            WH8.Range("C" & j).Value = WH2.Range("F" & i).Value
            WH8.Range("D" & j).Value = WH2.Range("D" & i).Value
            h = h + 1
          Case 0
            WH8.Range("F" & j).Value = WH2.Range("B" & i).Value
            WH8.Range("G" & j).Value = WH2.Range("E" & i).Value
            WH8.Range("H" & j).Value = WH2.Range("F" & i).Value
            WH8.Range("I" & j).Value = WH2.Range("D" & i).Value
            j = j + 1
            h = h + 1
        End Select
        WH2.Range(i & ":" & i).Delete
        LG = WH2.Range("A65536").End(xlUp).Row
        If LG > 2 Then
          Ramdam
        ElseIf LG <> 1 Then
          i = LG
        Else
          Exit Do
        End If
      Loop
     
    [4] 
      '列幅のオートフィット
      For i = 1 To 11
        WH8.Rows(i).EntireColumn.AutoFit
      Next
     
      'E列に"VS"入力して幅を変更
      LG = WH8.Range("A65536").End(xlUp).Row
      WH8.Range("E2:E" & LG).Value = "VS"
      WH8.Range("E:E").ColumnWidth = 20
     
     
      '1行ごとに罫線
      For i = 2 To LG
        WH8.Range("A" & i & ":I" & i).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Next
    End Sub
    ~~~~~~~~ソース3.-ここまで~~~~~~~~

    ソース3でやってること→1対1の組み合わせを作る
    [1]まずはLGに最終行を求めます。
     ※この段階のLGの値は「全体」と「項目行」なので全体数より1多い

     次に、そのLGを2で割ったあまりを求めます(modは除算のあまりを求める)
     ※ここで2で割っているのは、試合で1対1をやる場合1ゲームに
     「2人」が必要となるからです。

     その次に2で割っているのはループを回す数を求めるためです。
     
    [2]YobunIdouを実行(後述)
    [3]Kaisuuに格納された数の分だけループを回す
     1.列用の変数hの値が奇数の時は左の列に、偶数の時は右の列に
      データを格納します
     2.i列目のデータは格納されたら削除します
     3.残された行数(人数)が少なくなってきたらiの値は最終行

    [4]1.列幅のオートフィット
     2.互いの間に「VS」と入れ、列幅を20にする
     3.罫線を引く


    ~~~~~~~~ソース4.-ここから~~~~~~~~
    '=============================================
    '対戦-2対2
    '=============================================
    Sub MixDouble()
    [1]
      '=====全体の人数が奇数だった時に偶数に調整
      LG = WH2.Range("A65536").End(xlUp).Row
      If LG Mod 2 = 1 Then
        LG2 = LG - 1
        Kaisuu = (LG2 / 2) + 1
      End If

    [2]
      YobunIdou
     
    [3]
      Ramdam
     
      j = 2  'WH8-行用
      h = 1  'WH8-列用
      Do Until j > Kaisuu
        Select Case h Mod 2
          Case 1
            WH8.Range("A" & j).Value = WH2.Range("B" & i).Value
            WH8.Range("B" & j).Value = WH2.Range("E" & i).Value
            WH8.Range("C" & j).Value = WH2.Range("F" & i).Value
            WH8.Range("D" & j).Value = WH2.Range("D" & i).Value
            h = h + 1
          Case 0
            WH8.Range("F" & j).Value = WH2.Range("B" & i).Value
            WH8.Range("G" & j).Value = WH2.Range("E" & i).Value
            WH8.Range("H" & j).Value = WH2.Range("F" & i).Value
            WH8.Range("I" & j).Value = WH2.Range("D" & i).Value
            j = j + 1
            h = h + 1
        End Select
        WH2.Range(i & ":" & i).Delete
       
        LG = WH2.Range("A65536").End(xlUp).Row
        If LG > 2 Then
          Ramdam
        ElseIf LG <> 1 Then
          i = LG
        Else
          Exit Do
        End If
      Loop
     
    [4] 
      '列幅のオートフィット
      For i = 1 To 11
        WH8.Rows(i).EntireColumn.AutoFit
      Next
     
      'E列に"VS"入力して幅を変更
      LG = WH8.Range("A65536").End(xlUp).Row
      For i = 2 To LG Step 2
        WH8.Range("E" & i).Value = "VS"
        WH8.Range("E" & i & ":E" & i + 1).MergeCells = True
      Next
      WH8.Range("E:E").ColumnWidth = 20
     
     
      '1行ごとに罫線
      For i = 3 To LG Step 2
        WH8.Range("A" & i & ":I" & i).Borders(xlEdgeBottom).Weight = xlMedium
      Next
    End Sub
    ~~~~~~~~ソース4.-ここまで~~~~~~~~

    ソース4でやってること→2対2の組み合わせを作る
    [1]~[3]OneOnOneでやっていることと同じなので割愛
    [4]1.列幅のオートフィット
     2.「2行ごと」に「VS」の値を入れてセルを結合し、列幅を20にする
     3.「2行ごと」に罫線を引く
     
     ※「Step △」
      For文を書く時に、1行ずつの処理をしたい場合は何も書かなければ
      いいのですが、2行ごとや3行ごとなど飛ばし飛ばしの処理をしたい場合は
      「For 変数 = 始まりの数 To 終わりの数 Step 処理をしたい数」
      とする。

       今回の「For i = 3 To LG Step 2」の場合は
      変数iが3から始まりLGまで2行おきに処理がされます。
      

    ~~~~~~~~ソース5.-ここから~~~~~~~~
    '==========================================
    '余分な人数分をあまりスペースに格納
    '==========================================
    Sub YobunIdou()
      Ramdam
      LG = WH2.Range("A65536").End(xlUp).Row - 1
     
      Select Case Nin
        Case 1
          l = LG Mod 2
        Case 2
          l = LG Mod 4
      End Select
     
      k = 2
      If l > 0 And LG > 1 Then
        Do Until l = 0
          WH8.Range("K" & k).Value = WH2.Range("B" & l + 1).Value
          WH8.Range("L" & k).Value = WH2.Range("E" & l + 1).Value
          WH8.Range("M" & k).Value = WH2.Range("F" & l + 1).Value
          WH8.Range("N" & k).Value = WH2.Range("D" & l + 1).Value
          WH2.Range(l + 1 & ":" & l + 1).Delete
          k = k + 1
          l = l - 1
        Loop
      End If
    End Sub
    ~~~~~~~~ソース5.-ここまで~~~~~~~~

    ソース5でやってること→あまりになる人数分メンバーを抜き出す
    ・人数を求め、その最終行を2、または4で割る
     ※割る値は試合人数によって変わる
    ・試合人数が2人:あまりがある場合は最大1人
    ・試合人数が4人:あまりがある場合は最大3人
    ・最大人数を各数で割ったあまりの値の分ループさせ、
     シート「試合」のあまりスペースに代入していき、
     終了後はその行を削除する


    以下が条件別のユーザーフォームとその結果です
    [0]デフォルト

    5434a95f.JPG




















    02c08578.JPG














    [1]組み合わせ:混合、人数:2人、学年:1年・2年
    f736c9f4.JPG




















    05168810.JPG












    [2]組み合わせ:女子、人数:1人、学年:1年
    68fecf92.JPG




















    7e7302c9.JPG














    ここからはユーザーフォームの中のソースです
    ~~~~~~~~ソース6.-ここから~~~~~~~~
    '===================================
    'フォームを読み込む時に初期化
    '===================================
    Private Sub UserForm_Initialize()
      Me.OP混合.Value = True
      Me.OB全学年.Value = True
      Me.OB1人.Value = True
     
      With Me.ListBox1
        .AddItem "組み合わせ:混合"
        .AddItem "人数:1人"
        .AddItem "学年:全学年 "
      End With
    End Sub
    ~~~~~~~~ソース6.-ここまで~~~~~~~~

    ソース6でやっていること→初期化
    ・ユーザーフォームを読み込んだ時の処理です。
     「UserForm_Initialize」はユーザーフォームの処理で
     一番早くに実行されます
    ・ここでは組み合わせ、学年、人数のオプションに初期の値を入れ、
     リストボックスに現在の条件を格納


    ~~~~~~~~ソース7.-ここから~~~~~~~~
    '===================================================
    '開始ボタンを押した時
    '===================================================
    Private Sub CB開始_Click()
      Unload Me
    End Sub
    ~~~~~~~~ソース7.-ここまで~~~~~~~~

    ソース7でやっていること→ユーザーフォームを閉じる


    ~~~~~~~~ソース8.-ここから~~~~~~~~
    '========================================
    '組み合わせ
    '=========================================
    Private Sub OP混合_Click()
    [1]
      ListCNT = Me.ListBox1.ListCount - 1
      i = 0
     
    [2]
      NaiyouKakunou
     
    [3]
      Naiyou(0) = "組み合わせ:混合"
      i = 0
      Do Until i > ListCNT
        Me.ListBox1.AddItem Naiyou(i)
        i = i + 1
      Loop
      Kumiawase = "混合"
    End Sub
    ~~~~~~~~ソース8.-ここまで~~~~~~~~

    ソース8でやっていること→組み合わせ条件を選択
    [1]リストボックスの行数(-1)を求める
      ※リストボックス内の配列を扱うための値なので1を引く
       Ex)行数が1→配列は0
         行数が2→配列は0と1
    [2]マクロNaiyouKakunouの呼び出し(後述)
    [3]・変数Naiyou(0)に条件文を格納
      ※"組み合わせ:"までは同一、以降は混合・男子・女子と変わる
     ・リストボックスに条件の格納
     ・変数Kumiawaseに条件を格納(混合、男子、女子のいずれか)
     
     ☆以下に
       ・OB男子_Click
       ・OB女子_Click
      が続くが、やっていることは同じなので割愛


    ~~~~~~~~ソース9.-ここから~~~~~~~~
    '========================================
    '人数
    '=========================================
    Private Sub OB1人_Click()
    [1]
      ListCNT = Me.ListBox1.ListCount - 1
      i = 0

    [2] 
      NaiyouKakunou

    [3] 
      Naiyou(1) = "人数:1人"
      i = 0
      Do Until i > ListCNT
        Me.ListBox1.AddItem Naiyou(i)
        i = i + 1
      Loop
      Nin = 1
    End Sub
    ~~~~~~~~ソース9.-ここまで~~~~~~~~

    ソース9でやっていること→人数条件を選択
    [1]~[3]やっていることは大体同じ
    [3]変数Ninに指定人数を格納(1人:1、2人:2)

    ・変数Naiyou(0)に条件文を格納
      ※"組み合わせ:"までは同一、以降は混合・男子・女子と変わる
     ・リストボックスに条件の格納
     ・変数Kumiawaseに条件を格納(混合、男子、女子のいずれか)
     
     ☆以下に
       ・OB2人_Click
      が続くが、やっていることは同じなので割愛


    ~~~~~~~~ソース10.-ここから~~~~~~~~
    '========================================
    '学年
    '=========================================
    Private Sub OB全学年_Click()
    [1]
      ListCNT = Me.ListBox1.ListCount - 1
      i = 0

    [2]
      NaiyouKakunou

    [3]
      Naiyou(2) = "学年:全学年"
      i = 0
      Do Until i > ListCNT
        Me.ListBox1.AddItem Naiyou(i)
        i = i + 1
      Loop
      Gakunen = 0
    End Sub
    ~~~~~~~~ソース10.-ここまで~~~~~~~~

    ソース10でやっていること→学年条件を選択
    [1]~[3]やっていることは大体同じ
    [3]変数Gakunenに条件に合った値を入れる
     混合:0、1年:1、2年:2、3年:3、
     1・2年:12、1・3年:13、2・3年:23

     ☆以下に
       ・OB1年_Click
       ・OB2年_Click
       ・OB3年_Click
       ・OB1年2年_Click
       ・OB1年3年_Click
       ・OB2年と3年_Click
      が続くが、やっていることは同じなので割愛


    ~~~~~~~~ソース11.-ここから~~~~~~~~
    '===================================
    '内容を変数に入れておく
    '===================================
    Sub NaiyouKakunou()
      Do Until i > ListCNT
        Naiyou(i) = Me.ListBox1.List(i, 0)
        i = i + 1
      Loop
     
      Me.ListBox1.Clear
    End Sub
    ~~~~~~~~ソース11.-ここまで~~~~~~~~

    ソース11でやっていること→変数Naiyouにリストの値を移す
     ・現在入っているリストの内容をiの値が一致する
      配列変数Naiyouに格納していく
     ・格納後リストをクリア(これをしないと前のものの続きに
      データが入ってしまう)
      ※リストボックスへの「Add Item」で上書きは出来ません

     △「ListBox.List(行番号、列番号)」
      リストボックスの値を指定する場合おそらく一番簡単な方法。
      列数を指定していない場合、列数は必ず1列なので、
      配列的な考えで行くと「0」になります。
      行番号も同様の考え方をするので、1列目・3行目のデータを
      選ぶときは、
      「ListBox.List(2,0)」
      となります。


    以上で「試合」は終了です。
    ではお疲れ様でした~。

     

    拍手[0回]


    [1]  [2]  [3]  [4]  [5]  [6]  [7]  [8
    カレンダー
    10 2019/11 12
    S M T W T F S
    1 2
    3 5 6 7 8 9
    10 11 12 13 14 15 16
    17 18 19 20 21 22 23
    24 25 26 27 28 29 30
    ブログ内検索
    最新コメント
    [05/27 きり]
    [01/13 きり]
    [06/06 わんこ]
    [03/30 サイトウ]
    [06/09 yu]
    カウンター
    アクセス解析


    フリーエリア
    コガネモチ


        ◆ graphics by アンの小箱 ◆ designed by Anne ◆

        忍者ブログ [PR]