関数を作る_4（VBA研究会議事録_15）

VBA研究会で論じられた内容を記録する議事録の15本目（2023/05/13開催分）です。前回の議事録はコチラになります。

hirocom777.hatenadiary.org

Office365などに搭載されていて、それより前のExcelに搭載されていないワークシート関数を作ってみようという企画に取り組んでいます。前回まででいろいろな機能を持ったFunctionプロシージャを作成しました。

今回はいよいよワークシート関数として実装してみようと思います。

ワークシート関数

早速実際のコードなのですが、前回とほぼ同じです。異なるのは以下の2点です。

記述個所をシートモジュールから標準モジュールに移動
上記に伴って、コード内のシート指定をActiveSheetに変更

'テーブルの選択列を条件指定して1次元配列にする
Function columnToArray(ByVal tableName As String, _
                        ByVal columnName As String, _
                        Optional ByVal condition As String, _
                        Optional ByVal partialMatch As Boolean = False, _
                        Optional ByVal transferType As Long) _
                        As Variant

    Dim tarTable As ListObject: Set tarTable = Me.ListObjects(tableName)
    Dim tarColumn As ListColumn: Set tarColumn = tarTable.ListColumns(columnName)
    Dim tarArr As Variant: tarArr = WorksheetFunction.Transpose(tarColumn.DataBodyRange.Value)
    Dim dic As New Dictionary
    
    '部分一致、全体一致で絞込
    Dim tarVal As Variant
    For Each tarVal In tarArr
        If Not dic.Exists(tarVal) Then
            If partialMatch = True Then '部分一致
                If CStr(tarVal) Like "*" & condition & "*" Then
                    dic.Add tarVal, Null
                End If
            Else '全体一致
                If tarVal = condition Then
                    dic.Add tarVal, Null
                End If
            End If
        End If
    Next
   
    '指定がある場合は2次元配列に変換
    Dim tmpArr As Variant
    tmpArr = dic.Keys
    If transferType = xlRows Then 'n行1列に変換する
        tmpArr = transferNrow1Column(tmpArr)
    ElseIf transferType = xlColumns Then '1行n列に変換する
        tmpArr = transfer1rowNColumn(tmpArr)
    End If
        
    columnToArray = tmpArr

End Function

'n行1列に変換する
Function transferNrow1Column(ByVal tarArr As Variant) As Variant()
    
    transferNrow1Column = WorksheetFunction.Transpose(tarArr)

End Function

'1行n列に変換する
Function transfer1rowNColumn(ByVal tarArr As Variant) As Variant
    
    ReDim tmpArr(0, 0 To UBound(tarArr))
    Dim i As Long
    For i = LBound(tarArr) To UBound(tarArr)
        tmpArr(0, i) = tarArr(i)
    Next i
    transfer1rowNColumn = tmpArr

End Function