トーナメント作成 ③ 箱を罫線で繋ぐ

昨日は参加人数に合わせて、一回戦から優勝までの人名記入用セルを配置した。
infoment.hatenablog.com

今日は、この箱を罫線で縦横つなぐことに挑戦する。
f:id:Infoment:20191015184418p:plain

さて、まず横の線だが、これは名前のセルを結合する前に引いておくことにした。
f:id:Infoment:20191015212236p:plain

次いで、昨日のコードに「縦線」描画のループを追加する。
f:id:Infoment:20191015212345p:plain

Sub Sample()

    Cells.Clear
    
    ' トーナメント参加者リスト。
    ' ※シート1のなんちゃって個人情報を参照。
    ' ※この時点では、50人決め打ち。
    Dim arr() As Variant
        arr = Sheet1.Range("B2:B51").Value
    
    ' 参加者人数から、トーナメントが何回戦まで必要かを求める。
    Dim iMax As Long
        iMax = WorksheetFunction.RoundUp(WorksheetFunction.Log(UBound(arr), 2), 0)
    Dim i As Long
    Dim j As Long
    
        ' 1回戦~準決勝戦まで。
        For j = 1 To iMax
            ' j回戦の一人一人について。
            For i = 1 To (2 ^ iMax) / (2 ^ (j - 1))
                With Cells((2 * i - 1) * 2 ^ (j - 1), 3 * j - 2)
                    Select Case j
                        ' 横の罫線だけ、先に描画しておく。
                        ' ※セル結合により、人名入力セル内は罫線が無くなる。
                        Case 1
                            .Resize(, 2).Borders(xlEdgeBottom).Weight = xlThin
                        Case Else
                            .Resize(, 3).Offset(, -1).Borders(xlEdgeBottom).Weight = xlThin
                    End Select
                    .Resize(2).Merge
                    .Resize(2).Borders.Weight = xlThin
                End With
            Next
        Next
    
        ' 決勝戦。
        With Cells(2 ^ iMax, 3 * j - 2)
            .Resize(, 2).Offset(, -1).Borders(xlEdgeBottom).Weight = xlThin
            .Resize(2).Merge
            .Resize(2).Borders.Weight = xlThin
        End With
        
        ' 縦の線。
        For j = 1 To iMax
            For i = 1 To 2 ^ (iMax - j)
                Cells((2 ^ (j + 1)) * i - (3 * 2 ^ (j - 1) - 1), 3 * j - 1).Resize(2 ^ j).Borders(xlEdgeRight).Weight = xlThin
            Next
        Next

End Sub

結果、ここまで自動描画することが出来た。
f:id:Infoment:20191015212530p:plain

縦線のループを作成する過程で、随分と久しぶりに「階差数列」の式を求めた。
今回も、プログラミングというより数学の要素が強いかも。

ここまでは、前哨戦。ここからが、もっとややこしくなる予定なのだが。
まだ、考えをまとめ切れていない。さて、どうなることやら。

明日に続きます。

参考まで。

トーナメント作成 ② とりあえず箱を配置する

昨日は参加人数から、トーナメントが何回戦まで行われるか求めてみた。
infoment.hatenablog.com

今日はこれを利用して、決勝戦までの箱を並べてみる。
f:id:Infoment:20191014214908p:plain

まず参加者だが、今回も「なんちゃって個人情報」のお世話になった。
f:id:Infoment:20191014215005p:plain

これを手作業でシート上に配置すると、このようになる。なお、この時点では昨日同様、シード選手については検討していない。
f:id:Infoment:20191014215237p:plain

箱の描画は、以下の条件で行った。

  1. 名前は一人あたり、二行一列とする。
  2. 上記セルは組合せ表記上、結合する。
  3. 一回戦と二回戦の間は二列とする(以降も同様)。
  4. 二回戦の人名は、一回戦の対戦者の中間に配置する(以降も同様)。
  5. 組み合わせは、セルの罫線で描画する。

f:id:Infoment:20191014215819p:plain

Sub sample()
    Cells.Clear

    ' トーナメント参加者リスト。
    ' ※シート1のなんちゃって個人情報を参照。
    ' ※この時点では、50人決め打ち。
    Dim arr() As Variant
        arr = Sheet1.Range("A2:A51").Value
    
    ' 参加者人数から、トーナメントが何回戦まで必要かを求める。
    Dim iMax As Long
        iMax = WorksheetFunction.RoundUp(WorksheetFunction.Log(UBound(arr), 2), 0)
    Dim i As Long
    Dim j As Long
    
        ' 1回戦~準決勝戦まで。
        For j = 1 To iMax
            ' j回戦の一人一人について
            For i = 1 To (2 ^ iMax) / (2 ^ (j - 1))
                With Cells((2 * i - 1) * 2 ^ (j - 1), 3 * j - 2).Resize(2)
                    .Merge
                    .Borders.Weight = xlThin
                End With
            Next
        Next

        ' 決勝戦。
        With Cells(2 ^ iMax, 3 * j - 2).Resize(2)
            .Merge
            .Borders.Weight = xlThin
        End With
End Sub

 

ここまで来ると、プログラミングというより最早、算数の領域なのかな。
コードだけだと分かり難いので、手書きで恐縮だが数式でもご紹介。
f:id:Infoment:20191014221928p:plain

結果、箱までは描画することが出来た。
f:id:Infoment:20191014222130p:plain

この箱を、どうすればシンプルに繋げられるかが次の課題。
明日の晩まで、頭を捻るとしよう。

明日に続きます。

参考まで。

トーナメント作成 ① 2の倍数に切り上げる

とある事情から、簡単にトーナメント表を作りたくなった。
そこで、Excelで簡単に作れないか、今日から試してみようと思う。
手順など、恐らく世の中では既に確立しているのだろうが、勉強のためにもやってみよう。上手くいったら、ご喝采。失敗しても、ご愛敬ってことで。
f:id:Infoment:20191013094011p:plain

最初の挑戦として、トーナメントの段数を求めてみよう。二人ずつ戦って勝ち残りとなる訳だから、最後の一人になるためには、2の倍数で1回戦を構成すればよいと仮定する。

図に書くと、こんな感じだ。
f:id:Infoment:20191013094954p:plain

中途半端な場合、例えば6人の場合も、最初に片方ずつを埋めると考えれば成立しそうだ(書いていて、パウリの排他原理を思い出した)。

↓ 順番に片方から埋め、次いで残りを埋める。
※まず、埋めるだけ。
f:id:Infoment:20191013095327p:plain

↓ 対戦相手がいない場合、山を一つにする。
f:id:Infoment:20191013095538p:plain

なお、今は単純に統合しているだけなので、
どの選手がシードとなるかなどは、別途検討することにする。
以上のように考えれば、トーナメントの段数は、
 選手が「2のn乗」人であるとき、「n+1」段となる
と言えないだろうか。

では、その数が2の何乗になるかを求めるのは、どうすれば良いか。最もシンプルなのは、常用対数で求める方法だと思う。
ja.wikipedia.org

f:id:Infoment:20191013101849p:plain

これを踏まえれば、切り上げて1を加えることで、段数を求められそうだ。
f:id:Infoment:20191013102415p:plain

次回に続きます。

参考まで。

①と②の順序が入れ替わった時、自動で②を①に、①を②に変更したい。

突然、強烈に面倒くさくなった。
何が面倒くさいって、番号を一々入れ替えるのが。
f:id:Infoment:20191012135043p:plain

私の書く週報は、良し悪しはさておき、こんな書式になっている。
f:id:Infoment:20191012135150p:plain

例えば時系列の関係などから、①と②を入れ替えたとする。
f:id:Infoment:20191012135702p:plain

②と①の文字が自動で入れ替わるはずもなく、次いで手作業で修正が必要になる。
f:id:Infoment:20191012135822p:plain

これが、とても面倒くさい。

そこで、極めて限定的ではあるが、これが自動で入れ替わる関数を作成してみた。
限定的とした理由は、以下の制約があるから。

  1. ① ~ ⑳ のみ対応
  2. 数字は全て、同じ列になければならない
  3. 数字以外の文字が含まれてはならない。

作戦としては、こうだ。

  1. 一つ上の数字について、その文字コードを取得する。
  2. 取得した文字コードに1を加え、文字に変換して返す。

①は、パソコンの中では「-30912」という数字で管理されている。
②は、-30192 + 1 = -30191 といった具合。

これらを踏まえると実際は、こんな感じだ。

Function GetNextNumber(target_range As Range) As String
    Application.Volatile
    If target_range.Row = 1 Then
        GetNextNumber = "①"
    Else
        Dim BeforeNumber As String
            If target_range.Offset(RowOffset:=-1) <> vbNullString Then
                BeforeNumber = target_range.Offset(RowOffset:=-1).Value
            Else
                BeforeNumber = target_range.End(xlUp).Value
            End If

            If BeforeNumber = vbNullString Then
                GetNextNumber = "①"
            ElseIf Asc(BeforeNumber) >= -30912 And Asc(BeforeNumber) <= -30912 + 18 Then
                GetNextNumber = Chr(Asc(BeforeNumber) + 1)
            Else
                GetNextNumber = "①"
            End If
    End If
End Function

実際設定する時は、こんな感じだ。数式を書いているセルを、引数としている。
f:id:Infoment:20191012140738p:plain

それでは、入れ替えて実験してみよう。
f:id:Infoment:20191012141019g:plain

一応、想定した動きを実現できた。これで週報を書く時間と、文字入れ替えの面倒くささにまつわるストレスが、少しだけ低減できそうだ。
※決して、週報を書くのが面倒だと言っている訳ではないですよ?
 と、謎の言い訳を添えておきます。

参考まで。

B1の一つ右隣を指定する方法

先日、職場の勉強会で、あることに気づかせてもらった話を紹介した。
infoment.hatenablog.com

実はこの時もう一つ、気付かせてもらった話がある。
f:id:Infoment:20191010222838p:plain

といっても、言われてみれば、当たり前の話。社内勉強会に参加されたその方は、例えばB1の一つ右隣(つまりC1)を指定するとき、このように表現したのだった。

Sub Hoge()
    Range("B1").Offset(ColumnOffset:=1).Select
End Sub

私の中では、↓が定番となって既に久しい。

Range("B1").Offset(, 1).Select

行方向は移動が無いので、オフセット量は0。0の場合は省略できる。そして右はプラス方向。だから一つ隣は1と成り、.Offset(, 1) となる。

しかしこの方のように「名前付き引数」を使用すれば、「ColumnOffset」を見て、直感的に列方向のオフセットだと気づくことができる。若しくは推測できる。ポロポロと、目から鱗が落ちた。(, 1) に比べ、随分分かり易いと感じた。
(ただし、文字数は一番多くなる)。

ちなみに、他にも色々と表現方法がある。

Sub Hoge()
    Range("B1").Offset(, 1) = 1
    Range("B1").Offset(0, 1) = 2
    Range("B1").Offset(ColumnOffset:=1) = 3
    
    Range("B1").Range("B1") = 4
    Range("B1").Cells(1, 2) = 5
    Range("B1").Cells(ColumnIndex:=2) = 6
End Sub

f:id:Infoment:20191010224332g:plain

きっと、他にもあると思う。
どの方法を採用するかは各位、時と場合とお好みで。

参考まで。

Target と Selection と ActiveCell

職場の勉強会で、WorkSheet_SelectionChange イベントを扱う機会があった。
f:id:Infoment:20191008204839p:plain

選択範囲の値を得て、何某かの処理をする。私の中では、Target を使うのが定番。例えば、こんな感じだ。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 ' 複数セル選択によるエラーを回避。
    If Target.Count > 1 Then
        Exit Sub
    Else
        MsgBox Target.Value
    End If
End Sub

とここで、最近始めたばかりの参加者から、ActiveCellを使うという案が出た。確かにこの場合、以下のいずれも有効だ。

  • Selection (選択範囲)
  • Target (選択範囲)
  • ActiveCell (選択範囲のうち、一番左上のセル)

この内、先の二つは、複数範囲を選択するとエラーになる(「複数セルの値」を、そのままメッセージボックスには表示できない)。だからこそ先のサンプルでは、選択セルが1つを超える場合(つまり2個以上の場合)はExit Subとすることで、エラーを回避していた。

しかしActiveCell であれば、同時に複数のセルをアクティブにすることはできないので、複数範囲を選択してもエラーにならない。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    MsgBox ActiveCell.Value
End Sub

f:id:Infoment:20191008210148p:plain
考えてみれば極々自然なことなのに、今までそのように着想したことがなかった。
感謝。

初級と言えど、隅から隅まで知っている筈もなく。どのような講座であっても、
必ず何か一つ得るものがあるものだと、改めて思った次第です。

参考まで。

セル内で複数行に改行されている文字を、一行ずつ取得したい

セル内で、複数回改行されている文字列がある。
見やすさのためか、途中に空白行まで挟まっている。こんな感じで。
f:id:Infoment:20191006110452p:plain

この中から、

  1. ああああ
  2. いいいい
  3. うううう
  4. ええええ

の4つの文字列を取り出したいという依頼があった。
f:id:Infoment:20191006110827p:plain

拡張子は「.xls」だった。聞けば、昔から代々使われているファイルとのこと。
そこで、どのように改行されているか、一つずつSplit関数で分割し、その成否で
調べることにした。

改行コード 文字コード 機能
vbCr chr(13) キャリッジリターン カーソルを先頭に
vbLf chr(10) ラインフィード 次の行へ
vbCrLf chr(13)+chr(10) 上記組合せ
vbNewLine chr(13)+chr(10) 上記組合せ Windowsの場合

例えば、こんな感じだ。普通は無いと思うが、意地悪テストで、改行コードを混在させてみた。

Sub Hoge()
    Dim Str As String
        Str = "ああああ" & vbCr & _
              "いいいい" & vbLf & vbLf & _
              "うううう" & vbCrLf & _
              "ええええ" & vbNewLine
              
        Cells(1, 1).Resize(, 5) = Split(Str, vbCr)
        Cells(2, 1).Resize(, 5) = Split(Str, vbLf)
        Cells(3, 1).Resize(, 5) = Split(Str, vbCrLf)
        Cells(4, 1).Resize(, 5) = Split(Str, vbNewLine)
End Sub

結果は、以下のとおり。当たり前と言えば、当たり前で、常にどれかを分割しそこなっている。
f:id:Infoment:20191006113511p:plain

それにしても、毎回同じようなことを調べている。ならば、これをスッキリ分割できれば、都度調べる必要もないのではないか。

ということで、正規表現で改行コードを「,」に置き換えたうえで、分割してみた。

シンボル 機能
\n 改行にマッチ
\f vbLfにマッチ
\r vbCrにマッチ

それぞれ一つずつで3通り。
それぞれ二つずつで3通り。
3つ全部で1通り。
計7通りで確認した。

Sub Fuga()
    Dim Str As String
        Str = "ああああ" & vbCr & _
              "いいいい" & vbLf & vbLf & _
              "うううう" & vbCrLf & _
              "ええええ" & vbNewLine
        
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.Global = True
        
    Dim temp As String
        
        myReg.Pattern = "[\n]+"
        temp = myReg.Replace(Str, ",")
        Cells(5, 1).Resize(, 5) = Split(temp, ",")

        myReg.Pattern = "[\r]+"
        temp = myReg.Replace(Str, ",")
        Cells(6, 1).Resize(, 5) = Split(temp, ",")

        myReg.Pattern = "[\f]+"
        temp = myReg.Replace(Str, ",")
        Cells(7, 1).Resize(, 5) = Split(temp, ",")
        
        myReg.Pattern = "[\n\r]+"
        temp = myReg.Replace(Str, ",")
        Cells(8, 1).Resize(, 5) = Split(temp, ",")

        myReg.Pattern = "[\n\f]+"
        temp = myReg.Replace(Str, ",")
        Cells(9, 1).Resize(, 5) = Split(temp, ",")

        myReg.Pattern = "[\r\f]+"
        temp = myReg.Replace(Str, ",")
        Cells(10, 1).Resize(, 5) = Split(temp, ",")

        myReg.Pattern = "[\n\r\f]+"
        temp = myReg.Replace(Str, ",")
        Cells(11, 1).Resize(, 5) = Split(temp, ",")
End Sub

結果は、以下のとおり。
f:id:Infoment:20191006115019p:plain

今回は \nと \r の組合せ、および3つ全てで、改行コードが混在する文字列を分割することが出来た。

以上を踏まえたうえで、作成したのがこちら。もともと「,」がある場合を考え、最初の置き換えをvbNewLineにしてみた。

Function GetSplitLineArray(source As String) As Variant
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.Global = True
        myReg.Pattern = "[\n\r]+"
    Dim tempStr As String
        tempStr = myReg.Replace(source, vbLf)

        GetSplitLineArray = Split(tempStr, vbLf)
End Function

テストはこちら。

Sub test()
    Dim Str As String
        Str = "ああああ" & vbCr & _
              "いいいい" & vbLf & vbLf & _
              "うううう" & vbCrLf & _
              "ええええ" & vbNewLine
        MsgBox Join(GetSplitLineArray(Str), vbNewLine)
End Sub

f:id:Infoment:20191006120936p:plain

暫く運用してみて、問題が出たらまた改善することにしよう。

参考まで。