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


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


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

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

 

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

○ソース
～～～～～～～ソース１．-ここから～～～～～～～～
'============================================================
'選抜抜き出し
'============================================================
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 = "学年"
 

  '罫線を引く-２重線
  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行目の項目行を削除
　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]各グループに振り分け。変数ｈは行数、変数GroupNoは列数
　※GroupNoの場合、A～Cが１、D～Fが２となる
　→マクロSenbatuKaitenを呼び出し（後述）
[3]最終処理
　→最終列までのオートフィット

～～～～～～～ソース２．-ここから～～～～～～～～
'値入れ
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
 ～～～～～～～ソース２．-ここまで～～～～～～～～

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

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

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

「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文字目が斜体になる