自作マクロ機能の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の場合    異常終了　※配列の次元数が３以上。

' 配列の次元数を取得する関数
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

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

参考まで。