自作マクロ機能のAIアップグレード:配列の貼り付け

生成系AIの出現により、Excel マクロも随分と作りやすくなった。
そこで今回も、以前作成したものを改めてAIに添削してもらった。

素材となるのはこちら。
infoment.hatenablog.com
この中のうち、配列を指定範Excelでユーザー定義関数を作成。

AIへの指示がこちら。

関数名:PasteArray
引き数 target_range as range 配列を張り付ける開始点
引き数 source_array as variant 張り付けられる配列
引き数 optional transpose_flag as boolean=false 縦横を入れ替えて貼り付け

戻り値
 0の場合 正常終了
-1の場合 異常終了 ※target_arrayが配列ではない
-2の場合 異常終了 ※配列の次元数が3以上囲に張り付ける機能を作り直してみよう。

出来てきたのがこちら。

Function PasteArray(target_range As Range, source_array As Variant, Optional transpose_flag As Boolean = False) As Integer
    Dim i As Long, j As Long
    Dim numRows As Long, numCols As Long
    On Error GoTo ErrorHandler
    
    ' 配列が2次元または1次元であるかどうかを確認
    If IsArray(source_array) = False Then
        PasteArray = -1
        Exit Function
    End If
    
    ' 配列の次元数を取得
    Select Case True
        Case IsArray(source_array)
            If Not (IsArray(source_array) And IsArray(source_array(1))) Then
                ' 1次元配列の場合
                numRows = 1
                numCols = UBound(source_array) - LBound(source_array) + 1
            Else
                ' 2次元配列の場合
                numRows = UBound(source_array, 1) - LBound(source_array, 1) + 1
                numCols = UBound(source_array, 2) - LBound(source_array, 2) + 1
            End If
        Case Else
            PasteArray = -2
            Exit Function
    End Select
    
    ' 縦横を入れ替える場合
    If transpose_flag Then
        For i = 1 To numCols
            For j = 1 To numRows
                target_range.Cells(i, j).Value = source_array(j, i)
            Next j
        Next i
    Else
        For i = 1 To numRows
            For j = 1 To numCols
                target_range.Cells(i, j).Value = source_array(i, j)
            Next j
        Next i
    End If
    
    PasteArray = 0
    Exit Function

ErrorHandler:
    PasteArray = -1
End Function

なるほど、一次元も二次元も、ともに二次元配列にしたうえで張り付けるのか。

ちなみに、以前作成した際に不便だった点は、文字列が配列に格納されると同時に数値に変換されてしまうことだった。追加で指示してみよう。

Function PasteArray(target_range As Range, source_array As Variant, Optional transpose_flag As Boolean = False) As Integer
    Dim i As Long, j As Long
    Dim numRows As Long, numCols As Long
    On Error GoTo ErrorHandler
    
    ' 配列が2次元または1次元であるかどうかを確認
    If IsArray(source_array) = False Then
        PasteArray = -1
        Exit Function
    End If
    
    ' 配列の次元数を取得
    Select Case True
        Case IsArray(source_array)
            If Not (IsArray(source_array) And IsArray(source_array(1))) Then
                ' 1次元配列の場合
                numRows = 1
                numCols = UBound(source_array) - LBound(source_array) + 1
            Else
                ' 2次元配列の場合
                numRows = UBound(source_array, 1) - LBound(source_array, 1) + 1
                numCols = UBound(source_array, 2) - LBound(source_array, 2) + 1
            End If
        Case Else
            PasteArray = -2
            Exit Function
    End Select
    
    ' 縦横を入れ替える場合
    If transpose_flag Then
        For i = 1 To numCols
            For j = 1 To numRows
                target_range.Cells(i, j).Value = CStr(source_array(j, i))
            Next j
        Next i
    Else
        For i = 1 To numRows
            For j = 1 To numCols
                target_range.Cells(i, j).Value = CStr(source_array(i, j))
            Next j
        Next i
    End If
    
    PasteArray = 0
    Exit Function

ErrorHandler:
    PasteArray = -1
End Function

さらに、列の次元数を取得したうえで、縦横を入れ替えた配列を取得する部分を切り出して別の関数で作成してみよう。

'[用 途]
'   指定セルに配列を貼り付ける。

'[引 数]
'   target_range As Range     配列を貼り付けるセル
'   source_array As Variant   貼り付けられる配列

'[戻り値]
'    0の場合    正常終了
'   -1の場合    異常終了 ※target_arrayは配列ではない。
'   -2の場合    異常終了 ※配列の次元数が3以上。
' 配列の次元数を取得する関数
Function GetArrayDimensions(arr As Variant) As Integer
    Dim dimCount As Integer
        dimCount = 0
        On Error Resume Next
        Do
            dimCount = dimCount + 1
        Loop Until IsEmpty(LBound(arr, dimCount))
        On Error GoTo 0
        
        GetArrayDimensions = dimCount - 1
End Function
' 配列の縦横を入れ替える関数
Function TransposeArray(arr As Variant) As Variant
    Dim numRows As Long
        numRows = UBound(arr, 1)
    Dim numCols As Long
        numCols = UBound(arr, 2)
    Dim result() As Variant
    ReDim result(1 To numCols, 1 To numRows)
    Dim i As Long
    Dim j As Long
        For i = 1 To numRows
            For j = 1 To numCols
                result(j, i) = arr(i, j)
            Next
        Next
        
        TransposeArray = result
End Function
' 配列を指定したセル範囲に貼り付ける関数
Function PasteArray(target_range As Range, source_array As Variant, Optional transpose_flag As Boolean = False) As Integer
    On Error GoTo ErrorHandler
    
    ' 配列が有効であるかどうかを確認
    If Not IsArray(source_array) Then
        PasteArray = -1
        Exit Function
    End If
    
    ' 配列の次元数を取得
    Dim arrayDimensions As Integer
        arrayDimensions = GetArrayDimensions(source_array)
        If arrayDimensions > 2 Then
            PasteArray = -2
            Exit Function
        End If
    
    ' 配列の縦横を入れ替えるかどうかをチェック
    Dim transposedArray As Variant
        If transpose_flag Then
            If arrayDimensions = 1 Then
                ' 1次元配列の場合、単純に縦横を入れ替える
                Dim numRows As Long
                    numRows = UBound(source_array) - LBound(source_array) + 1
                Dim numCols As Long
                    numCols = 1
                ReDim transposedArray(1 To numRows, 1 To numCols)
                Dim i As Long
                    For i = 1 To numRows
                        transposedArray(i, 1) = source_array(i)
                    Next i
            Else
                ' 2次元配列の場合、TransposeArray関数を使用
                transposedArray = TransposeArray(source_array)
                numRows = UBound(transposedArray, 1)
                numCols = UBound(transposedArray, 2)
            End If
        Else
            transposedArray = source_array
            If arrayDimensions = 1 Then
                numRows = 1
                numCols = UBound(source_array) - LBound(source_array) + 1
            Else
                numRows = UBound(source_array, 1)
                numCols = UBound(source_array, 2)
            End If
        End If
    
    ' 値をセルに貼り付ける
    Dim j As Long
        For i = 1 To numRows
            For j = 1 To numCols
                target_range.Cells(i, j).Value = CStr(transposedArray(i, j))
            Next
        Next
    
        PasteArray = 0
        Exit Function

ErrorHandler:
        PasteArray = -1
End Function

結果として、元々作成したものに似た形になってしまった。文字列として値を貼り付ける点が改善されたため、これも一つの進化系といえるかな。AIさん、さすがです。

参考まで。

自作マクロ機能のAIアップグレード:FindAll

生成系AIの出現により、ここ数年で色々なものが随分と様変わりした。
最近ではExcel VBAにおいても、仕様をAIに伝えて作ってもらうことが多くなった。

そこで今回は、以前作成したものの「いまいち」だったマクロを、改めてAIに添削してもらった。素材となるのはこちら。
infoment.hatenablog.com

添削結果がこちら。

Function FindAll(target_range As Range, _
                 faWhat As String, _
        Optional faLookIn As Excel.XlFindLookIn = xlValues, _
        Optional faLookAt As Excel.XlLookAt = xlPart, _
        Optional faMatchCase As Boolean = False, _
        Optional faMatchByte As Boolean = False) As Range

    Dim FindCell As Range
    Dim FirstAddress As String
    Dim TempRange As Range

    ' 最初の一致を見つける
    Set FindCell = target_range.Find(What:=faWhat, _
                                     LookIn:=faLookIn, _
                                     LookAt:=faLookAt, _
                                     MatchCase:=faMatchCase, _
                                     MatchByte:=faMatchByte)
    
    ' 一致するものがない場合、関数を終了する
        If FindCell Is Nothing Then
            Exit Function
        End If
    
    ' 最初に見つかったセルのアドレスを保存する
        FirstAddress = FindCell.Address
    Set TempRange = FindCell
    
    ' すべての一致を見つけるためにループ
        Do
            Set FindCell = target_range.FindNext(FindCell)
            If FindCell Is Nothing Then Exit Do ' セーフティチェック
            If FindCell.Address = FirstAddress Then Exit Do
            ' 新しいセルが既にTempRangeに含まれていないかを確認
            If Intersect(TempRange, FindCell) Is Nothing Then
                Set TempRange = Union(TempRange, FindCell)
            End If
        Loop
    
    ' 一致するすべての範囲を返す
    Set FindAll = TempRange
End Function

なるほど、確かにすっきりした。しかし、丸投げはよくない。テストしよう。

Sub test()

    FindAll(ActiveSheet.Cells, "ターゲット").Interior.Color = vbRed

End Sub

結果がこちら。

AIさん、さすがです。
ご参考まで。

マインクラフト:メンガーのスポンジをコマンドで作成

最近、子供と一緒にマインクラフトで遊んでいる。
先日、メンガーのスポンジを作るコマンドを作ってみたので、備忘録がてら紹介。
ja.wikipedia.org

  • X軸(よこ軸)
  • Y軸(高さ軸)
  • Z軸(たて軸)

とするとき、まず起点となるブロックを一つ置いてみる。
↓ 3×3×3の立方体の一段目。

この000(相対座標)のブロックを、適切な箇所にコピーしていく。
白抜きの箇所が、コピーしてはいけない箇所。

↓二段目(白抜きの箇所はコピー不可)。

↓三段目(白抜きの箇所はコピー不可)。

結果、このような基本形が出来上がる。

これを一つのブロックと見立てて、どうようにコピーを繰り返すことでフラクタル図形ができていく。

ところでこの「コピーする/しない」、何か法則を見つけて自動化できないか。
試しに表にしてみた。

・・・法則が見つけられない。ということで、試しに全部1引いてみた。すると、0の数が2以上のときにコピー不可であることが分かった。
※恐らくは、すでに広く一般的に知られている法則と思われる。

ここまでわかれば、あとはコマンド化するだけだ。というわけで作ってみた。

count_zeros = 0
def check_zeros(a: number, b: number, c: number):
    global count_zeros
    count_zeros = 0
    if a == 0:
        count_zeros += 1
    if b == 0:
        count_zeros += 1
    if c == 0:
        count_zeros += 1
    return count_zeros <= 1

def on_on_chat(origin_x, origin_y, origin_z):
    blocks.place(PLANKS_ACACIA, world(origin_x, origin_y, origin_z))
    for n in range(5):
        for index_x in range(3):
            for index_y in range(3):
                for index_z in range(3):
                    if check_zeros(index_x - 1, index_y - 1, index_z - 1):
                        blocks.clone(world(origin_x, origin_y, origin_z),
                            world(origin_x + 3 ** n - 1,
                                origin_y + 3 ** n - 1,
                                origin_z + 3 ** n - 1),
                            world(origin_x + index_x * 3 ** n,
                                origin_y + index_y * 3 ** n,
                                origin_z + index_z * 3 ** n),
                            CloneMask.REPLACE,
                            CloneMode.NORMAL)
player.on_chat("Menger_sponge", on_on_chat)

結果がこちら。

参考まで。

再びトーナメント表作成 ➈-6 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。

今日は、三つに分けたサブプロシージャの最後。

    Dim Sh As Worksheet
    Set Sh = ActiveSheet
        ' トーナメント作成用シートを変数にセットしてリネーム。
        Sh.Name = SheetName
        
        ' 各選手の「番号」を、辞書を利用して「人名」に置換。
        For Each r In Sh.UsedRange.Columns(1).Cells
            If r <> vbNullString Then
                r = PDict(r.Value)
            End If
        Next

        ' 配列内で、選手名が空欄であれば「不戦敗」に置き換える。これにより、
        ' 対戦相手がシード選手となる。
        For i = 1 To UBound(arr)
            If arr(i, 列名.enNo) = vbNullString Then
                arr(i, 列名.enNo) = "不戦敗"
            
            ' 形のトーナメント作成である場合、この後に続く組手トーナメント作成時に
            ' 形と同カードが発生しないよう、形の対戦組み合わせを辞書に記録する。
            ElseIf match_type = en形 Then
                If WorksheetFunction.IsOdd(i) Then
                    If arr(i, 列名.enNo) <> vbNullString And arr(i + 1, 列名.enNo) <> vbNullString Then
                        DDict(arr(i, 列名.enNo)) = arr(i + 1, 列名.enNo)
                        DDict(arr(i + 1, 列名.enNo)) = arr(i, 列名.enNo)
                    End If
                End If
            End If
        Next
        
        With DstTb
            If .ListRows.Count > 0 Then
                .DataBodyRange.Delete
            End If
            .ListRows.Add
            .DataBodyRange.Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
        End With
        
        If DuplicateTimes > 0 Then
            MsgBox SheetName & "で、二回戦までに " & DuplicateTimes & " 箇所で同所属選手対戦の恐れがあります。確認および調整をお願いします。"
        End If
        
End Sub

これで、対戦表およびトーナメント作成までの機能が完成した。

それでは次回、実際に作成されたものをみてみよう。

参考まで。

※その後、数々の仕様変更があって、いったん保留となりました。

再びトーナメント表作成 ➈-5 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。

昨日は「前半と後半の二回に分ける」としたが、それでも長かった。
ということで、今日は中盤のご紹介。同一サブプロシージャの途中から始まるため分り難くなっているが、最後に改めてまとめて紹介するため、今はご勘弁。

        Do
            With New VBAProject.Tournament
                ' トーナメント作成の初期設定。
                ' 前回順位の最大値を取得し、それ以降をランダムに並び替える。
                .init Tb.ListColumns(列名.enNo).DataBodyRange, True, _
                      WorksheetFunction.Max(Tb.ListColumns(列名.en前回形順位).DataBodyRange) + 1
                      
                    ' トーナメントの配列取得。
                    arr = TournamentArray(.TournamentSortedOrderArray, match_type)
                    
                    ' 同所属対戦を不可とするブロック単位で、同所属の対戦が無いかを確認する。
                    For i = 1 To UBound(arr) Step DupTrial
                        
                        ' 重複の有無は辞書で行う。そのため、ループに入るたびに辞書を空にしている。
                        Dict.RemoveAll
                        
                        For j = 0 To DupTrial - 1
                            
                            ' 一回戦においては空欄=シードが存在するため、それ以外の場合で評価している。
                            ' keyの重複を不可とする仕様を利用しているため、itemは不問。今回はTrueとした。
                            If arr(i + j, 列名.en所属) <> vbNullString Then
                                If Not Dict.Exists(arr(i + j, 列名.en所属)) Then
                                    Dict(arr(i + j, 列名.en所属)) = True
                                Else
                                    ' 重複があった場合は、重複回数をカウントアップ。
                                    DuplicateTimes = DuplicateTimes + 1
                                End If
                            End If
                        Next
                    Next
                    
                    ' 重複回数が重複許容回数を下回る場合であって、且つ組手のトーナメントを作成している場合、
                    ' 一回戦で形トーナメントと同じ選手と対戦していないかを確認。対戦している場合は再組合せ。
                    If DuplicateTimes < AllowableDuplicateTimes And match_type = en組手 Then
                        For i = 1 To UBound(arr) Step 2
                            If DDict.Exists(arr(i, 列名.enNo)) Then
                                If DDict(arr(i, 列名.enNo)) = arr(i + 1, 列名.enNo) Then
                                    ' 同じ選手と対戦している場合、重複回数を強制的に重複許容回数とすることで
                                    ' 再抽選させる。
                                    DuplicateTimes = AllowableDuplicateTimes
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                    
                    ' ループ回数が最大値を超えた場合の処理。
                    If LoopCount > LoopCountMax Then
                        MsgboxResult = MsgBox("組み合わせをランダムに" & LoopCountMax & "回作成しましたが、同所属の対戦を回避できませんでした。" & vbNewLine & _
                                                         "このままの組み合わせで継続しますか?", vbYesNo, "処理継続確認")
                        If MsgboxResult = vbNo Then
                            MsgBox "処理を中断しました。"
                            Exit Sub
                        Else
                            ' 同所属の対戦があるままトーナメント作成。人の手で最終調整。
                            .CreateTournament
                            Exit Do
                        End If
                    
                    ' 重複回数が許容重複回数を下回っている場合、トーナメント作成の条件達成。
                    ' トーナメントを作成してループを抜ける。
                    ElseIf DuplicateTimes < AllowableDuplicateTimes Then
                        .CreateTournament
                        Exit Do
                    End If
            End With
            LoopCount = LoopCount + 1
            
            ' 重複回数の初期化。
            DuplicateTimes = 0
        Loop

以下の条件においては、どうしても一回戦での同一所属対戦が増えてしまう。

  1. 選手数が多く、且つ、参加団体数が少ない場合。
  2. 2^nよりもほんの少しだけ、参加人数が多い場合。

例えば2^4=16人より一人多い17人の場合について考えてみる。この場合、一回戦は1組のみで、残りの対戦はすべてシードとなる。

そのため、一回戦だけ同所属対戦を回避しても、どうしても二回戦(実質一回戦)での同一所属対戦が発生してしまう。
例)一回戦シードのため、二回戦で長野県同士で対戦となる。

これを回避すべく、昨日紹介範囲になるが、4人一組で同一部門の人がいないことを条件としてみた。

次回に続きます。

参考まで。

再びトーナメント表作成 ➈-4 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、先日の続きから。

本日は、トーナメントの作成部分。長いので、前半と後半で日を分けて紹介。

Sub 対戦表作成(Optional match_type As MatchType = en形)

    Call 名簿データ取得
    
    ' 形および組手の名簿は、PowerQueryで作成。
    ' 名簿テーブル。
    Dim Tb As ListObject
    ' 対戦表テーブル。
    Dim DstTb As ListObject
    ' トーナメントを作成するシート名。
    Dim SheetName As String
        Select Case match_type
            Case MatchType.en形
                Set Tb = S22_名簿_形.Tb
                Set DstTb = S24_対戦表_形.Tb
                Set DDict = New Scripting.Dictionary
                SheetName = "形トーナメント"
             Case MatchType.en組手
                Set Tb = S23_名簿_組手.Tb
                Set DstTb = S25_対戦表_組手.Tb
                SheetName = "組手トーナメント"
        End Select
    
    ' 作成済みシートの有無確認。ある場合は削除する。
    Dim Ws As Worksheet
        Application.DisplayAlerts = False
        For Each Ws In Worksheets
            If Ws.Name = SheetName Then
                Ws.Delete
                Exit For
            End If
        Next
        Application.DisplayAlerts = True
    
    ' 名簿テーブルの更新。BackgroundQueryをFalseにすることで、
    ' QueryTableの更新が終わってから次のステップに進む。
        Tb.QueryTable.Refresh BackgroundQuery:=False
    
    ' 組み合わせ表を格納するための配列。
    Dim arr As Variant
    ' 同一所属間対戦をチェックするための辞書。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    ' ループ用変数。
    Dim i As Long
    Dim j As Long
    ' ループカウンタ。
    Dim LoopCount As Long
    ' 重複数。形と組手で同じ人と対戦した回数。
    Dim DuplicateTimes As Long
    ' 許容重複回数。
    Dim AllowableDuplicateTimes As Long: AllowableDuplicateTimes = 2
    ' 再履行許容回数。重複などが解消できない場合、無限ループに入る恐れがある。
    ' そのため、再履行の最大値を設定しておく。
    Dim LoopCountMax As Long: LoopCountMax = 10000
    Dim MsgboxResult As VbMsgBoxResult
    Dim r As Range
    ' 同所属対戦を許容するブロックの人数。
    ' 例)2 とした場合、一回戦のみ同所属対戦不可とする。
    '    4 とした場合、二回戦まで同所属対戦不可とする。一回戦がシードの場合、
    '    二回戦まで不可としておくことで、シード戦の同所属対戦を回避できる。
    '    出場団体が少ないほど同所属対戦が起きやすくなるため、調整が必要。
    Dim DupTrial As Long: DupTrial = 4

以下の条件を如何に満足させるかが、今回苦労した点。

  1. 初戦での同門対決回避。
  2. 形と組手での同一組み合わせ回避。

結果、いくつかの辞書を作成しては中身を廃棄の繰り返しとなった。
きっと、もっとうまい方法があったに違いない。

次回に続きます。

参考まで。

再びトーナメント表作成 ➈-3 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。

昨日と同様の標準モジュールに、 以下を追加する。

' トーナメントの対戦順に並び替えられた配列に、その他の基本情報を付加して新たな配列を返す。
' source_array:トーナメント対戦表。
' match_type:形または組手の区分。
Function TournamentArray(source_array As Variant, match_type As MatchType) As Variant
    Dim i As Long
    ' データ格納用配列。
    Dim arr() As Variant
    ReDim arr(1 To UBound(source_array), 1 To 列名.[_eLast] - 3)
    
    ' No.は、キー情報。通し番号または各団体の登録番号などを想定。
        For i = 1 To UBound(source_array)
            arr(i, 1) = source_array(i)
            For Each p In Persons
                If source_array(i) = p.No Then
                    arr(i, 列名.en名前) = p.名前
                    arr(i, 列名.enふりがな) = p.ふりがな
                    arr(i, 列名.en性別) = p.性別
                    arr(i, 列名.en学校等区分) = p.学校等区分
                    arr(i, 列名.en学年) = p.学年
                    arr(i, 列名.en所属) = p.所属
                    Select Case match_type
                        Case MatchType.en形
                            arr(i, 列名.en形出場) = p.形出場
                            arr(i, 列名.en前回形順位) = p.前回形順位
                        Case MatchType.en組手
                            arr(i, 列名.en形出場) = p.組手出場
                            arr(i, 列名.en前回形順位) = p.前回組手順位
                    End Select
                End If
            Next
        Next
        
        TournamentArray = arr
End Function

少し短いが、しばらく毎日更新も目標の一つのため、今日はここまで。

参考まで。