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

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

今日は、この箱を罫線で縦横つなぐことに挑戦する。

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

次いで、昨日のコードに「縦線」描画のループを追加する。

Sub Sample()

    Cells.Clear
    
    ' トーナメント参加者リスト。
    ' ※シート１のなんちゃって個人情報を参照。
    ' ※この時点では、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
    
        ' １回戦～準決勝戦まで。
        For j = 1 To iMax
            ' ｊ回戦の一人一人について。
            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

結果、ここまで自動描画することが出来た。

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

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

明日に続きます。

参考まで。

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

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

今日はこれを利用して、決勝戦までの箱を並べてみる。

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

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

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

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

Sub sample()
    Cells.Clear

    ' トーナメント参加者リスト。
    ' ※シート１のなんちゃって個人情報を参照。
    ' ※この時点では、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
    
        ' １回戦～準決勝戦まで。
        For j = 1 To iMax
            ' ｊ回戦の一人一人について
            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

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

結果、箱までは描画することが出来た。

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

明日に続きます。

参考まで。

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

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

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

図に書くと、こんな感じだ。

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

↓ 順番に片方から埋め、次いで残りを埋める。
※まず、埋めるだけ。

↓ 対戦相手がいない場合、山を一つにする。

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

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

これを踏まえれば、切り上げて１を加えることで、段数を求められそうだ。

次回に続きます。

参考まで。

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

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

私の書く週報は、良し悪しはさておき、こんな書式になっている。

例えば時系列の関係などから、①と②を入れ替えたとする。

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

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

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

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

作戦としては、こうだ。

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

①は、パソコンの中では「-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

実際設定する時は、こんな感じだ。数式を書いているセルを、引数としている。

それでは、入れ替えて実験してみよう。

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

参考まで。

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

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

実はこの時もう一つ、気付かせてもらった話がある。

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

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

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

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

行方向は移動が無いので、オフセット量は０。０の場合は省略できる。そして右はプラス方向。だから一つ隣は１と成り、.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

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

参考まで。

Target と Selection と ActiveCell

職場の勉強会で、WorkSheet_SelectionChange イベントを扱う機会があった。

選択範囲の値を得て、何某かの処理をする。私の中では、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 （選択範囲のうち、一番左上のセル）

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

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

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

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

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

参考まで。

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

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

この中から、

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

の４つの文字列を取り出したいという依頼があった。

拡張子は「.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

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

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

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

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

それぞれ一つずつで３通り。
それぞれ二つずつで３通り。
３つ全部で１通り。
計７通りで確認した。

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

結果は、以下のとおり。

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

以上を踏まえたうえで、作成したのがこちら。もともと「，」がある場合を考え、最初の置き換えを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

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

参考まで。